mirror of
https://github.com/KevinMidboe/linguist.git
synced 2025-10-29 17:50:22 +00:00
Merged with upstream. Updated M (aka MUMPS) detection to use the new bayesian / samples method.
This commit is contained in:
Laurent Parenteau
23
samples/M/GMRGPNB0.m
Normal file
23
samples/M/GMRGPNB0.m
Normal file
@@ -0,0 +1,23 @@
|
||||
GMRGPNB0 ;CISC/JH/RM-NARRATIVE BUILDER FOR TEXT GENERATOR (cont.) ;6/20/91
|
||||
;;3.0;Text Generator;;Jan 24, 1996
|
||||
TEXT ; ENTRY WITH GMRGA SET TO POINT AT WHICH WANT TO START BUILDING TEXT
|
||||
S (GMRGE0,GMRGADD)=""
|
||||
Q:'$D(^GMR(124.3,GMRGPDA,1,"ALIST",GMRGA0))&GMRGCSW Q:('$D(^GMR(124.3,"B",GMRGA0,GMRGPDA))&'$D(^GMR(124.3,GMRGPDA,1,"B",GMRGA0)))&'GMRGCSW D NOW^%DTC
|
||||
S GMRGB0=$O(^GMR(124.3,GMRGPDA,1,"B",GMRGA0,0)) I GMRGB0>0 S GMRGST=GMRGB0,GMRGST(1)=GMRGPDA,GMRGST(2)=$S(GMRGCSW=1:%,1:GMRGPDT) D STAT^GMRGRUT0 S GMRGF0=GMRGSTAT,GMRGST=GMRGB0,GMRGST(1)=GMRGPDA,GMRGST(2)=GMRGPDT D STAT^GMRGRUT0
|
||||
I GMRGB0>0 S GMRGE0=$S($P(GMRGSTAT,"^",3)=1:"",$P(GMRGSTAT,"^")=$P(GMRGF0,"^"):$S($D(^GMR(124.3,GMRGPDA,1,GMRGB0,0)):$P(^(0),"^",2),1:""),1:$S($D(^GMR(124.3,GMRGPDA,1,GMRGB0,2,+$P(GMRGSTAT,"^"),0)):$P(^(0),"^",4),1:""))
|
||||
I S GMRGADD=$S($P(GMRGSTAT,"^",3)=1:"",$P(GMRGSTAT,"^")=$P(GMRGF0,"^"):$S($D(^GMR(124.3,GMRGPDA,1,GMRGB0,"ADD")):"1;"_GMRGB0_";0",1:""),1:$S($D(^GMR(124.3,GMRGPDA,1,GMRGB0,2,$P(GMRGSTAT,"^"),"ADD")):"1;"_GMRGB0_";2;"_$P(GMRGSTAT,"^"),1:""))
|
||||
S GMRGE0(0)=$S($D(^GMRD(124.2,GMRGA0,0)):^(0),1:""),GMRGE0(4)=$S($D(^GMRD(124.2,GMRGA0,4)):^(4),1:""),GMRGE0(5)=$S($D(^GMRD(124.2,GMRGA0,5)):^(5),1:"") Q:$P(GMRGE0(0),"^",2)=3&GMRGSSW
|
||||
I "S"[$P(GMRGE0(0),"^",8)!GMRGSSW D SNT^GMRGPNB1 Q
|
||||
S GMRGNAR=GMRGPAR_"^"_$P(GMRGE0(0),"^",8)_"^"_GMRGSPC_"^^"_GMRGRM,GMRGNAR(0)=$P(GMRGE0(0),"^")_"^"_GMRGE0,GMRGNAR("LEAD")=GMRGE0(4),GMRGNAR("TRAIL")=GMRGE0(5) D STORETXT^GMRGRUT1
|
||||
S GMRGSPC=GMRGSPC+3
|
||||
F GMRGD0=0:0 S GMRGD0=$O(^GMRD(124.2,GMRGA0,1,GMRGD0)) Q:GMRGD0'>0 D RECUR
|
||||
Q:'GMRGADD
|
||||
S GMRGNAR=GMRGPAR_"^T^"_GMRGSPC_"^^"_GMRGRM,GMRGNAR("LEAD")="Additional Text: ",GMRGNAR("TRAIL")=""
|
||||
S GMRGNAR(0)=$S('$P(GMRGADD,";",3):^GMR(124.3,GMRGPDA,1,$P(GMRGADD,";",2),"ADD"),1:^GMR(124.3,GMRGPDA,1,$P(GMRGADD,";",2),2,$P(GMRGADD,";",4),"ADD")) D STORETXT^GMRGRUT1
|
||||
Q
|
||||
RECUR ;
|
||||
Q:'$$ALIST^GMRGRUT0(GMRGPDA,GMRGA0,+$G(^GMRD(124.2,+GMRGA0,1,+GMRGD0,0)))
|
||||
S ^TMP($J,"GMRGPLVL",GMRGPLVL)=GMRGA0_"^"_GMRGD0_"^"_GMRGSPC_"^"_GMRGSSW_"^"_GMRGADD,GMRGPLVL=GMRGPLVL+1,GMRGA0=$S($D(^GMRD(124.2,GMRGA0,1,GMRGD0,0)):$P(^(0),"^"),1:"")
|
||||
D TEXT
|
||||
S GMRGPLVL=GMRGPLVL-1,GMRGI0=^TMP($J,"GMRGPLVL",GMRGPLVL),GMRGA0=$P(GMRGI0,"^"),GMRGD0=$P(GMRGI0,"^",2),GMRGSPC=$P(GMRGI0,"^",3),GMRGSSW=$P(GMRGI0,"^",4),GMRGADD=$P(GMRGI0,"^",5)
|
||||
Q
|
||||
2460
samples/M/MDB.m
Normal file
2460
samples/M/MDB.m
Normal file
File diff suppressed because it is too large
Load Diff
34
samples/M/PRCAAPR.m
Normal file
34
samples/M/PRCAAPR.m
Normal file
@@ -0,0 +1,34 @@
|
||||
PRCAAPR ;WASH-ISC@ALTOONA,PA/RGY-PATIENT ACCOUNT PROFILE (CONT) ;3/9/94 8:41 AM
|
||||
V ;;4.5;Accounts Receivable;**198,221**;Mar 20, 1995
|
||||
;;Per VHA Directive 10-93-142, this routine should not be modified.
|
||||
EN(PRCATY) ;
|
||||
NEW DIC,X,Y,DEBT,PRCADB,DA,PRCA,COUNT,OUT,SEL,BILL,BAT,TRAN,DR,DXS,DTOUT,DIROUT,DIRUT,DUOUT
|
||||
ASK N DPTNOFZY,DPTNOFZK S (DPTNOFZY,DPTNOFZK)=1
|
||||
K OUT S COUNT=0 R !,"Select DEBTOR NAME or BILL NUMBER: ",X:DTIME I "^"[$E(X) S $P(DEBT,"^",2)="" G Q
|
||||
S X=$$UPPER^VALM1(X)
|
||||
S Y=$S($O(^PRCA(430,"B",X,0)):$O(^(0)),$O(^PRCA(430,"D",X,0)):$O(^(0)),1:-1)
|
||||
I Y>0 S DEBT=$P($G(^PRCA(430,Y,0)),"^",9) I DEBT S PRCADB=$P($G(^RCD(340,DEBT,0)),"^"),^DISV(DUZ,"^PRCA(430,")=Y,$P(DEBT,"^",2)=$$NAM^RCFN01(DEBT) D COMP,EN1^PRCAATR(Y) G:$D(DTOUT) Q G ASK
|
||||
S DIC="^RCD(340,",DIC(0)="E" D ^DIC G:Y<0 ASK
|
||||
S ^DISV(DUZ,"^RCD(340,")=+Y,PRCADB=$P(Y,"^",2),DEBT=+Y_"^"_$P(@("^"_$P(PRCADB,";",2)_+PRCADB_",0)"),"^")
|
||||
D COMP,HDR^PRCAAPR1,HDR2^PRCAAPR1,DIS^PRCAAPR1 G:'$D(DTOUT) ASK
|
||||
Q K ^TMP("PRCAAPR",$J) Q
|
||||
COMP ;Compile patient bills
|
||||
K ^TMP("PRCAAPR",$J)
|
||||
NEW STAT,STAT1,CNT,Y
|
||||
S STAT1=0
|
||||
F CNT=1:1 S STAT1=+$S(PRCATY="ALL":$O(^PRCA(430,"AS",+DEBT,STAT1)),1:$O(^PRCA(430.3,"AC",+$P(PRCATY,",",CNT),0))) Q:'STAT1 F BILL=0:0 S BILL=$O(^PRCA(430,"AS",+DEBT,STAT1,BILL)) Q:'BILL D COMP1
|
||||
I PRCADB[";DPT(" F BILL=0:0 S BILL=$O(^PRCA(430,"E",+PRCADB,BILL)) Q:'BILL I PRCATY="ALL"!((","_PRCATY_",")[(","_$P($G(^PRCA(430.3,+$P($G(^PRCA(430,BILL,0)),"^",8),0)),"^",3)_",")) D COMP1
|
||||
F BAT=0:0 S BAT=$O(^RCY(344,"AC",PRCADB,BAT)) Q:'BAT F TRAN=0:0 S TRAN=$O(^RCY(344,"AC",PRCADB,BAT,TRAN)) Q:'TRAN I $G(^RCY(344,BAT,1,TRAN,0))]"",$P(^(0),"^",5)="" D COMP2
|
||||
Q
|
||||
COMP1 S STAT=$P($G(^PRCA(430.3,+$P($G(^PRCA(430,BILL,0)),"^",8),0)),"^",3) Q:STAT=""
|
||||
S X=$G(^PRCA(430,BILL,7)),Y=$P(X,"^")+$P(X,"^",2)+$P(X,"^",3)+$P(X,"^",4)+$P(X,"^",5)
|
||||
I $P(^PRCA(430,BILL,0),"^",2)=$O(^PRCA(430.2,"AC",33,0)) S Y=-Y
|
||||
S Y=$S($P(^PRCA(430,BILL,0),"^",2)=$O(^PRCA(430.2,"AC",33,0))&(STAT'=112):0,$P(^PRCA(430,BILL,0),"^",9)'=+DEBT:0,",102,107,112,"[(","_STAT_","):Y,1:0)
|
||||
S ^TMP("PRCAAPR",$J,"C")=$G(^TMP("PRCAAPR",$J,"C"))+Y
|
||||
S ^TMP("PRCAAPR",$J,"C",STAT)=$G(^TMP("PRCAAPR",$J,"C",STAT))+Y_"^"_STAT,^(STAT,BILL)=$P(X,"^",1,5)
|
||||
Q
|
||||
COMP2 ;Compile payments
|
||||
S Y=$P(^RCY(344,BAT,1,TRAN,0),"^",4)
|
||||
S ^TMP("PRCAAPR",$J,"C")=$G(^TMP("PRCAAPR",$J,"C"))-Y
|
||||
S ^TMP("PRCAAPR",$J,"C",99)=$G(^TMP("PRCAAPR",$J,"C",99))-Y_"^99",^TMP("PRCAAPR",$J,"C",99,$P(^RCY(344,BAT,0),"^")_"-"_TRAN)=$P(^RCY(344,BAT,1,TRAN,0),"^",4)
|
||||
Q
|
||||
203
samples/M/PXAI.m
Normal file
203
samples/M/PXAI.m
Normal file
@@ -0,0 +1,203 @@
|
||||
PXAI ;ISL/JVS,ISA/KWP,ESW - PCE DRIVING RTN FOR 'DATA2PCE' API ;6/20/03 11:15am
|
||||
;;1.0;PCE PATIENT CARE ENCOUNTER;**15,74,69,102,111,112,130,164,168**;Aug 12, 1996;Build 14
|
||||
Q
|
||||
;
|
||||
;+ 1 2 3 4 5 6 7 8 9
|
||||
DATA2PCE(PXADATA,PXAPKG,PXASOURC,PXAVISIT,PXAUSER,PXANOT,ERRRET,PXAPREDT,PXAPROB,PXACCNT) ;+API to pass data for add/edit/delete to PCE.
|
||||
;+ PXADATA (required)
|
||||
;+ PXAPKG (required)
|
||||
;+ PXASOURC (required)
|
||||
;+ PXAVISIT (optional) is pointer to a visit for which the data is to
|
||||
;+ be related. If the visit is not known then there must be
|
||||
;+ the ENCOUNTER nodes needed to lookup/create the visit.
|
||||
;+ PXAUSER (optional) this is a pointer to the user adding the data.
|
||||
;+ PXANOT (optional) set to 1 if errors are to be displayed to the screen should only be set while writing and debugging the initial code.
|
||||
;+ ERRRET (optional) passed by reference. If present will return PXKERROR
|
||||
;+ array elements to the caller.
|
||||
;+ PXAPREDT (optional) Set to 1 if you want to edit the Primary Provider
|
||||
;+ only use if for the moment that editing is being done. (dangerous)
|
||||
;+ PXAPROB (optional) A dotted variable name. When errors and
|
||||
;+ warnings occur, They will be passed back in the form
|
||||
;+ of an array with the general description of the problem.
|
||||
;+ IF ERROR1 - (GENERAL ERRORS)
|
||||
;+ PXAPROB($J,SUBSCRIPT,"ERROR1",PASSED IN 'FILE',PASSED IN FIELD,
|
||||
;+ SUBSCRIPT FROM PXADATA)
|
||||
;+ PXAPROB(23432234,2,"ERROR1","PROVIDER","NAME",7)="BECAUSE..."
|
||||
;+ IF WARNING2 - (GENERAL WARNINGS)
|
||||
;+ PXAPROB($J,SUBSCRIPT,"WARNING2",PASSED IN 'FILE',PASSED IN FIELD,
|
||||
;+ SUBSCRIPT FROM PXADATA)
|
||||
;+ PXAPROB(23432234,3,"WARNING2","PROCEDURE","QTY",3)="BECAUSE..."
|
||||
;+ IF WARNING3 - (WARNINGS FOR SERVICE CONNECTION)
|
||||
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"AO")=REASON
|
||||
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"EC")=REASON
|
||||
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"IR")=REASON
|
||||
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"SC")=REASON
|
||||
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"MST")=REASON
|
||||
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"HNC")=REASON
|
||||
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"CV")=REASON
|
||||
;+ PXAPROB($J,1,"WARNING3","ENCOUNTER",1,"SHAD")=REASON
|
||||
;+ IF ERROR4 - (PROBLEM LIST ERRORS)
|
||||
;+ PXAPROB($J,6,"ERROR4","PX/DL",(SUBSCRIPT FROM PXADATA))=REASON
|
||||
;+ PXACCNT (optional) passed by reference. Returns the PFSS Account Reference if known.
|
||||
; Returned as null if the PFSS Account Reference is located in the Order file(#100)
|
||||
;+
|
||||
;+
|
||||
;+ Returns:
|
||||
;+ 1 if no errors and process completely
|
||||
;+ -1 if errors occurred but processed completely as possible
|
||||
;+ -2 if could not get a visit
|
||||
;+ -3 if called incorrectly
|
||||
;
|
||||
NEW ;--NEW VARIABLES
|
||||
N NOVSIT,PXAK,DFN,PXAERRF,PXADEC,PXELAP,PXASUB
|
||||
N PATIENT,VALQUIET,PRIMFND
|
||||
K PXAERROR,PXKERROR,PXAERR,PRVDR
|
||||
S PXASUB=0,VALQUIET=1
|
||||
; needs to look up if not passed.
|
||||
I '$G(PXAVISIT),'$D(@PXADATA@("ENCOUNTER")) Q -3
|
||||
I $G(PXAUSER)<1 S PXAUSER=DUZ
|
||||
;
|
||||
K ^TMP("PXK",$J),^TMP("DIERR",$J),^TMP("PXAIADDPRV",$J)
|
||||
SOR ;--SOURCE
|
||||
I PXAPKG=+PXAPKG S PXAPKG=PXAPKG
|
||||
E S PXAPKG=$$PKG2IEN^VSIT(PXAPKG)
|
||||
I PXASOURC=+PXASOURC S PXASOURC=PXASOURC
|
||||
E S PXASOURC=$$SOURCE^PXAPIUTL(PXASOURC)
|
||||
;
|
||||
D TMPSOURC^PXAPIUTL(PXASOURC) ;-SAVES & CREATES ^TMP("PXK",$J,"SOR")
|
||||
VST ;--VISIT
|
||||
;--KILL VISIT
|
||||
I $G(PXAVISIT) D VPTR^PXAIVSTV I $G(PXAERRF) D ERR Q -2
|
||||
D VST^PXAIVST
|
||||
I $G(PXAVISIT)<0 Q -2
|
||||
I $G(PXAERRF) D ERR K PXAERR Q -2
|
||||
PRV ;--PROVIDER
|
||||
S PATIENT=$P($G(^AUPNVSIT(PXAVISIT,0)),"^",5)
|
||||
S (PXAK,PRIMFND)=0
|
||||
F S PXAK=$O(@PXADATA@("PROVIDER",PXAK)) Q:(PRIMFND)!(PXAK="") D
|
||||
.I $D(@PXADATA@("PROVIDER",PXAK,"PRIMARY")) D
|
||||
..S PRIMFND=$G(@PXADATA@("PROVIDER",PXAK,"PRIMARY"))
|
||||
I 'PRIMFND D ;Check for each provider's status as Primary or Secondary
|
||||
.S PXAK=0 F S PXAK=$O(@PXADATA@("PROVIDER",PXAK)) Q:PXAK="" D
|
||||
..I '$D(@PXADATA@("PROVIDER",PXAK,"PRIMARY")) D PROVDRST
|
||||
S PXAK=0 F S PXAK=$O(@PXADATA@("PROVIDER",PXAK)) Q:PXAK="" D
|
||||
. D PRV^PXAIPRV I $G(PXAERRF) D ERR
|
||||
K PRI ;--FLAG FOR PRIMARY PROVIDER
|
||||
K PXAERR
|
||||
POV ;--DIAGNOSIS
|
||||
S (PXAK,PRIMFND)=0
|
||||
F S PXAK=$O(@PXADATA@("DX/PL",PXAK)) Q:(PXAK="") D Q:PRIMFND
|
||||
.I +$G(@PXADATA@("DX/PL",PXAK,"PRIMARY"))=1 D
|
||||
..S PRIMFND=$G(@PXADATA@("DX/PL",PXAK,"DIAGNOSIS"))
|
||||
I $D(@PXADATA@("DX/PL")) D POVPRM(PXAVISIT,PRIMFND,.PXADATA) D
|
||||
.S PXAK=0 F S PXAK=$O(@PXADATA@("DX/PL",PXAK)) Q:PXAK="" D
|
||||
..D POV^PXAIPOV I $G(PXAERRF) D ERR
|
||||
K PXAERR
|
||||
;
|
||||
CPT ;--PROCEDURE
|
||||
S PXAK=0 F S PXAK=$O(@PXADATA@("PROCEDURE",PXAK)) Q:PXAK="" D
|
||||
. D CPT^PXAICPT I $G(PXAERRF) D ERR
|
||||
K PXAERR
|
||||
;
|
||||
EDU ;--PATIENT EDUCATION
|
||||
S PXAK=0 F S PXAK=$O(@PXADATA@("PATIENT ED",PXAK)) Q:PXAK="" D
|
||||
. D EDU^PXAIPED I $G(PXAERRF) D ERR
|
||||
K PXAERR
|
||||
;
|
||||
EXAM ;--EXAMINATION
|
||||
S PXAK=0 F S PXAK=$O(@PXADATA@("EXAM",PXAK)) Q:PXAK="" D
|
||||
. D EXAM^PXAIXAM I $G(PXAERRF) D ERR
|
||||
K PXAERR
|
||||
;
|
||||
HF ;--HEALTH FACTOR
|
||||
S PXAK=0 F S PXAK=$O(@PXADATA@("HEALTH FACTOR",PXAK)) Q:PXAK="" D
|
||||
. D HF^PXAIHF I $G(PXAERRF) D ERR
|
||||
K PXAERR
|
||||
;
|
||||
IMM ;--IMMUNIZATION
|
||||
S PXAK=0 F S PXAK=$O(@PXADATA@("IMMUNIZATION",PXAK)) Q:PXAK="" D
|
||||
. D IMM^PXAIIMM I $G(PXAERRF) D ERR
|
||||
K PXAERR
|
||||
;
|
||||
SKIN ;--SKIN TEST
|
||||
S PXAK=0 F S PXAK=$O(@PXADATA@("SKIN TEST",PXAK)) Q:PXAK="" D
|
||||
. D SKIN^PXAISK I $G(PXAERRF) D ERR
|
||||
K PXAERR
|
||||
;
|
||||
;
|
||||
D OTHER^PXAIPRV
|
||||
;
|
||||
;
|
||||
I $D(^TMP("PXK",$J)) D
|
||||
. D EN1^PXKMAIN
|
||||
. M ERRRET=PXKERROR
|
||||
. D PRIM^PXAIPRV K PRVDR
|
||||
. D EVENT^PXKMAIN
|
||||
S PXACCNT=$P($G(^AUPNVSIT(PXAVISIT,0)),"^",26) ;PX*1.0*164 ;Sets the PFSS Account Reference, if any
|
||||
K ^TMP("PXK",$J),PXAERR,PXKERROR
|
||||
Q $S($G(PXAERRF):-1,1:1)
|
||||
;
|
||||
;
|
||||
EXIT ;--EXIT AND CLEAN UP
|
||||
D EVENT^PXKMAIN
|
||||
K ^TMP("PXK",$J),PRVDR
|
||||
K PXAERR
|
||||
Q
|
||||
;-----------------SUBROUTINES-----------------------
|
||||
ERR ;
|
||||
;
|
||||
;
|
||||
I '$D(PXADI("DIALOG")) Q
|
||||
N NODE,SCREEN
|
||||
S PXAERR(1)=$G(PXADATA),PXAERR(2)=$G(PXAPKG),PXAERR(3)=$G(PXASOURC)
|
||||
S PXAERR(4)=$G(PXAVISIT),PXAERR(5)=$G(PXAUSER)_" "_$P($G(^VA(200,PXAUSER,0)),"^",1)
|
||||
I $G(PXANOT)=1 D EXTERNAL
|
||||
E D INTERNAL
|
||||
D ARRAY^PXAICPTV
|
||||
K PXADI("DIALOG")
|
||||
Q
|
||||
;
|
||||
EXTERNAL ;---SEND ERRORS TO SCREEN
|
||||
W !,"-----------------------------------------------------------------"
|
||||
D BLD^DIALOG($G(PXADI("DIALOG")),.PXAERR,"","SCREEN","F")
|
||||
D MSG^DIALOG("ESW","",50,10,"SCREEN")
|
||||
;
|
||||
Q
|
||||
INTERNAL ;---SET ERRORS TO GLOBAL ARRAY
|
||||
S NODE=PXADATA
|
||||
D BLD^DIALOG($G(PXADI("DIALOG")),.PXAERR,.PXAERR,NODE,"F")
|
||||
S NODE=$NA(@PXADATA@("DIERR",$J)) D MSG^DIALOG("ESW","",50,10,NODE)
|
||||
Q
|
||||
;
|
||||
PROVDRST ; Check provider status (Primary or Secondary)
|
||||
N PRVIEN,DETS,DIC,DR,DA,DIQ,PRI,PRVPRIM
|
||||
I $G(PXAK)="" QUIT
|
||||
S PRVIEN=0
|
||||
F S PRVIEN=$O(^AUPNVPRV("AD",PXAVISIT,PRVIEN)) Q:PRVIEN="" D
|
||||
.S DETS=$G(^AUPNVPRV(PRVIEN,0))
|
||||
.I $P(DETS,U)=$G(@PXADATA@("PROVIDER",PXAK,"NAME")) D
|
||||
..S DIC=9000010.06,DR=.04,DA=PRVIEN
|
||||
..S DIQ="PRVPRIM(",DIQ(0)="EI" D EN^DIQ1
|
||||
..S PRI=$E($G(PRVPRIM(9000010.06,DA,DR,"E")),1,1)
|
||||
..S @PXADATA@("PROVIDER",PXAK,"PRIMARY")=$S(PRI="P":1,1:0)
|
||||
Q
|
||||
POVPRM(VISIT,PRIMFND,POVARR) ;
|
||||
N PRVIEN,DETS,STOP,LPXAK,ORDX,NDX,ORDXP
|
||||
S PRVIEN=0
|
||||
;create array of existing DX; ORDX - pointer to ^ICD9(
|
||||
F S PRVIEN=$O(^AUPNVPOV("AD",PXAVISIT,PRVIEN)) Q:PRVIEN="" D
|
||||
.S DETS=$G(^AUPNVPOV(PRVIEN,0)),ORDX=$P(DETS,U)
|
||||
.S ORDX(ORDX)=PRVIEN I $P(DETS,U,12)="P" S ORDXP(ORDX)=""
|
||||
; create array of passed DX; NDX - pointer to ^ICD9(
|
||||
S PXAK=0 F S PXAK=$O(@POVARR@("DX/PL",PXAK)) Q:PXAK="" D
|
||||
.S NDX=$G(@POVARR@("DX/PL",PXAK,"DIAGNOSIS")) S NDX(NDX)=PXAK
|
||||
; force entry of originally primary diagnosis with "S" flag
|
||||
I PRIMFND S ORDX="" D
|
||||
.F S ORDX=$O(ORDXP(ORDX)) Q:ORDX="" I PRIMFND'=ORDX D
|
||||
..I $D(NDX(ORDX)) S @POVARR@("DX/PL",NDX(ORDX),"PRIMARY")=0
|
||||
..E D
|
||||
...S LPXAK=$O(@POVARR@("DX/PL",""),-1)
|
||||
...S @POVARR@("DX/PL",LPXAK+1,"DIAGNOSIS")=ORDX
|
||||
...S @POVARR@("DX/PL",LPXAK+1,"PRIMARY")=0
|
||||
Q
|
||||
;
|
||||
112
samples/M/WVBRNOT.m
Normal file
112
samples/M/WVBRNOT.m
Normal file
@@ -0,0 +1,112 @@
|
||||
WVBRNOT ;HCIOFO/FT,JR IHS/ANMC/MWR - BROWSE NOTIFICATIONS; ;7/30/98 11:02
|
||||
;;1.0;WOMEN'S HEALTH;;Sep 30, 1998
|
||||
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
|
||||
;; CALLED BY OPTION: "WV BROWSE NOTIFICATIONS" TO BROWSE AND EDIT
|
||||
;; NOTIFICATIONS.
|
||||
;
|
||||
;---> VARIABLES:
|
||||
;---> WVA: 1=ALL PATIENTS, 0=ONE PATIENT
|
||||
;---> WVDFN: DFN OF SELECTED PATIENT
|
||||
;---> DATES: WVBEGDT=BEGINNING DATE, WVENDDT=ENDING DATE
|
||||
;---> WVB: d=DELINQUENT, o=OPEN, q=queued, a=ALL (includes CLOSED).
|
||||
;---> SORT SEQUENCE IN WVC: 1=DATE, PATIENT, PRIORITY
|
||||
;---> 2=PATIENT, DATE, PRIORITY
|
||||
;---> 3=PRIORITY, DATE, PATIENT
|
||||
;---> USE NODES 3 & 4 IN ^TMP GLOBAL.
|
||||
;
|
||||
D SETVARS^WVUTL5
|
||||
D ^WVBRNOT2 G:WVPOP EXIT
|
||||
D SORT
|
||||
D COPYGBL
|
||||
D ^WVBRNOT1
|
||||
;
|
||||
EXIT ;EP
|
||||
D KILLALL^WVUTL8
|
||||
Q
|
||||
;
|
||||
;
|
||||
SORT ;EP
|
||||
;---> SORT AND STORE ARRAY IN ^TMP("WV",$J
|
||||
K ^TMP("WV",$J)
|
||||
;---> WVBEGDT1=ONE SECOND BEFORE BEGIN DATE.
|
||||
;---> WVENDDT1=THE LAST SECOND OF END DATE.
|
||||
S WVBEGDT1=WVBEGDT-.0001,WVENDDT1=WVENDDT+.9999
|
||||
;
|
||||
;**************************
|
||||
;---> WVA=1: ALL PATIENTS
|
||||
I WVA D Q
|
||||
.;---> BY DATE GET EITHER ALL OR OPEN ONLY.
|
||||
.N WVDFN,WVIEN,Y
|
||||
.S WVXREF=$S(WVB="a":"D",WVB="q":"APRT",1:"AOPEN")
|
||||
.S WVDATE=WVBEGDT1
|
||||
.F S WVDATE=$O(^WV(790.4,WVXREF,WVDATE)) Q:'WVDATE!(WVDATE>WVENDDT1) D
|
||||
..S WVIEN=0
|
||||
..F S WVIEN=$O(^WV(790.4,WVXREF,WVDATE,WVIEN)) Q:'WVIEN D
|
||||
...Q:'$D(^WV(790.4,WVIEN,0))
|
||||
...S Y=^WV(790.4,WVIEN,0),WVDFN=$P(Y,U)
|
||||
...;---> QUIT IF SELECTING FOR ONE CASE MANAGER AND THIS DOESN'T MATCH.
|
||||
...I 'WVE Q:$P(^WV(790,WVDFN,0),U,10)'=WVCMGR
|
||||
...;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.
|
||||
...I WVB="d" Q:$P(Y,U,13)'<DT!($P(Y,U,13)="")
|
||||
...D STORE
|
||||
;
|
||||
;**************************
|
||||
;---> WVA=0: ONE PATIENT
|
||||
N WVIEN,Y S WVIEN=0
|
||||
F S WVIEN=$O(^WV(790.4,"B",WVDFN,WVIEN)) Q:'WVIEN D
|
||||
.S Y=^WV(790.4,WVIEN,0)
|
||||
.;---> QUIT IF NOT WITHIN DATE RANGE.
|
||||
.S WVDATE=$P(Y,U,2)
|
||||
.Q:WVDATE'>WVBEGDT1!(WVDATE>WVENDDT1)
|
||||
.;---> QUIT IF "QUEUED" AND THIS NOTIFICATION IS NOT QUEUED.
|
||||
.I WVB="q" Q:'$P(Y,U,11) Q:'$D(^WV(790.4,"APRT",$P(Y,U,11),WVIEN))
|
||||
.;---> QUIT IF "DELINQUENT" OR OPEN ONLY AND THIS ENTRY IS CLOSED.
|
||||
.Q:"do"[WVB&($P(Y,U,14)="c")
|
||||
.I WVB="d" Q:$P(Y,U,13)'<DT!($P(Y,U,13)="")
|
||||
.D STORE
|
||||
Q
|
||||
;
|
||||
STORE ;EP
|
||||
;--->WVDATE IS ALREADY SET FROM LL SORT ABOVE. ;---> DATE
|
||||
S WVCHRT=$$SSN^WVUTL1(WVDFN)_" " ;---> SSN#
|
||||
S WVNAME=$$NAME^WVUTL1(WVDFN) ;---> NAME
|
||||
S WVACC=$P(Y,U,6) ;---> ACCESSION#
|
||||
I WVACC]"" S WVACC=$P(^WV(790.1,WVACC,0),U)
|
||||
S WVSTAT=$$STATUS^WVUTL4 ;---> STATUS
|
||||
S WVPRIO=9
|
||||
S:$P(Y,U,4)]"" WVPRIO=$P(^WV(790.404,$P(Y,U,4),0),U,2) ;---> PRIORITY
|
||||
;
|
||||
S X=WVCHRT_U_WVNAME_U_WVDATE_U_WVACC_U_WVSTAT_U_WVPRIO_U_WVIEN
|
||||
I WVC=1 S ^TMP("WV",$J,3,WVDATE,WVNAME,WVPRIO,WVIEN)=X Q
|
||||
I WVC=2 S ^TMP("WV",$J,3,WVNAME,WVDATE,WVPRIO,WVIEN)=X Q
|
||||
I WVC=3 S ^TMP("WV",$J,3,WVPRIO,WVDATE,WVNAME,WVIEN)=X
|
||||
Q
|
||||
;
|
||||
COPYGBL ;EP
|
||||
;---> COPY ^TMP("WV",$J,3 TO ^TMP("WV",$J,4 TO MAKE IT FLAT.
|
||||
N I,M,N,P,Q
|
||||
S N=0,I=0
|
||||
F S N=$O(^TMP("WV",$J,3,N)) Q:N="" D
|
||||
.S M=0
|
||||
.F S M=$O(^TMP("WV",$J,3,N,M)) Q:M="" D
|
||||
..S P=0
|
||||
..F S P=$O(^TMP("WV",$J,3,N,M,P)) Q:P="" D
|
||||
...S Q=0
|
||||
...F S Q=$O(^TMP("WV",$J,3,N,M,P,Q)) Q:Q="" D
|
||||
....S I=I+1,^TMP("WV",$J,4,I)=^TMP("WV",$J,3,N,M,P,Q)
|
||||
Q
|
||||
;
|
||||
;
|
||||
DEQUEUE ;EP
|
||||
;---> TASKMAN QUEUE OF PRINTOUT.
|
||||
D SETVARS^WVUTL5,SORT,COPYGBL,^WVBRNOT1,EXIT
|
||||
Q
|
||||
;
|
||||
FOLLOW(WVDFN) ;EP
|
||||
;---> CALLED FROM PROCEDURE FOLLOWUP MENU.
|
||||
D SETVARS^WVUTL5
|
||||
S WVA=0,WVB="o",WVBEGDT=(DT-50000),WVC=1,WVE=1,WVENDDT=DT
|
||||
D DEVICE^WVBRNOT2 Q:WVPOP
|
||||
S WVLOOP=1
|
||||
D SORT,COPYGBL,^WVBRNOT1
|
||||
Q
|
||||
171
samples/M/ZDIOUT1.m
Normal file
171
samples/M/ZDIOUT1.m
Normal file
@@ -0,0 +1,171 @@
|
||||
ZDIOUT1 ; Experimental FileMan file output to host file
|
||||
;---------------------------------------------------------------------------
|
||||
; Copyright 2011 The Open Source Electronic Health Record Agent
|
||||
;
|
||||
; Licensed under the Apache License, Version 2.0 (the "License");
|
||||
; you may not use this file except in compliance with the License.
|
||||
; You may obtain a copy of the License at
|
||||
;
|
||||
; http://www.apache.org/licenses/LICENSE-2.0
|
||||
;
|
||||
; Unless required by applicable law or agreed to in writing, software
|
||||
; distributed under the License is distributed on an "AS IS" BASIS,
|
||||
; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||||
; See the License for the specific language governing permissions and
|
||||
; limitations under the License.
|
||||
;---------------------------------------------------------------------------
|
||||
N W "Experimental FileMan file output to host file",!
|
||||
D ASKFILE Q:FILE["^"
|
||||
D ASKDIR Q:DIR["^"
|
||||
D SAVEFILE(FILE,DIR)
|
||||
Q
|
||||
SAVEFILE(FILE,DIR) ; Save FILE to given host directory
|
||||
I '$$SLASH(DIR) Q
|
||||
N FGR S FGR=$$FGR(FILE) Q:'$$CHECK(FGR,"Not a valid file number: "_FILE)
|
||||
S IO=DIR_$P($E(FGR,2,$L(FGR)),"(")_"+"_$$FILENAME(FILE,FGR)_".txt"
|
||||
W IO,!
|
||||
C IO O IO:("WNS"):1 E U $P W "Cannot open """_IO_""" for write!",! Q
|
||||
D FILE("",FILE,FGR)
|
||||
C IO
|
||||
Q
|
||||
PRNFILE(FILE,IO) ; Print FILE, optionally to IO device
|
||||
S:'$D(IO) IO=$P
|
||||
N FGR S FGR=$$FGR(FILE) Q:'$$CHECK(FGR,"Not a valid file number: "_FILE)
|
||||
D FILE("",FILE,FGR)
|
||||
Q
|
||||
PRNENTRY(FILE,I,IO) ; Print FILE record #I, optionally to IO device
|
||||
S:'$D(IO) IO=$P
|
||||
N FGR S FGR=$$FGR(FILE) Q:'$$CHECK(FGR,"Not a valid file number: "_FILE)
|
||||
N DD D DDCR(FILE,.DD)
|
||||
D ENTITY("",FILE,.DD,$$EGR(FGR,I))
|
||||
Q
|
||||
PRNDD(FILE,IO) ; Print DD for FILE, optionally to IO device
|
||||
S:'$D(IO) IO=$P
|
||||
; DD(FILE) is a file#0 whose entries define fields of FILE
|
||||
N FGR S FGR=$NA(^DD(FILE))
|
||||
I '$D(@FGR) W "Not a valid file number: "_FILE,! Q
|
||||
D FILE("",0,FGR)
|
||||
Q
|
||||
;---------------------------------------------------------------------------
|
||||
; Private implementation entry points below.
|
||||
; References cite the VA FileMan 22.0 Programmer Manual.
|
||||
;
|
||||
ASKFILE ; Ask for file number
|
||||
R !,"File#: ",FILE G:FILE="" ASKFILE Q:FILE["^" S FILE=+FILE
|
||||
S FGR=$$FGR(FILE)
|
||||
I '$$CHECK(FGR," (Not a valid file number)") G ASKFILE
|
||||
W " ",$$FILENAME(FILE,FGR)
|
||||
Q
|
||||
ASKDIR ; Ask for host dir
|
||||
R !,!,"Host output directory: ",DIR,! Q:DIR["^" G:'$$SLASH(DIR) ASKDIR
|
||||
Q
|
||||
SLASH(DIR) ; Validate trailing slash
|
||||
I $E(DIR,$L(DIR))?1(1"/",1"\") Q 1
|
||||
E U $P W "Output directory must end in a slash!" Q 0
|
||||
FGR(FILE) ; Get FILE Global Root
|
||||
Q $$ROOT^DILFD(FILE,"",1)
|
||||
EGR(FGR,I) ; Get ENTRY Global Root
|
||||
Q $NA(@FGR@(I))
|
||||
CHECK(V,MSG) ; Validate non-empty value
|
||||
I V="" W MSG,! Q 0
|
||||
Q 1
|
||||
DDCR(FILE,DD) ; X-ref global subscript location to DD field
|
||||
; The DD field definition 0-node has ^-pieces "^^^S;P^" where
|
||||
; "S;P" is the node Subscript and Piece within the node value (14.9.2).
|
||||
N F S F="" F S F=$O(^DD(FILE,F)) Q:F="" D:+F
|
||||
. N F4,S,P S F4=$P(^DD(FILE,F,0),"^",4),S=$P(F4,";",1),P=$P(F4,";",2) Q:S=" "
|
||||
. S DD(S,F)=P ; Subscript S contains field F at piece P
|
||||
Q
|
||||
FILE(D,FILE,FGR) ; Write all entries in a file
|
||||
; TODO: Sort entries by .01 or KEY to ensure consistent order
|
||||
N DD D DDCR(FILE,.DD)
|
||||
N I S I="" F S I=$O(@FGR@(I)) Q:I="" D
|
||||
. I +I D
|
||||
. . D ENTITY(D,FILE,.DD,$$EGR(FGR,I))
|
||||
. E D ; TODO: Handle known non-entry subscripts such as "B"
|
||||
. . D SUBS(D,$$EGR(FGR,I),I)
|
||||
Q
|
||||
WP(D,FGR) ; Write a word-processing value
|
||||
; A word processing field is actually a file in which each entry has a
|
||||
; .01 field containing the line of text, and the type of the field has "W".
|
||||
U IO W D,";",$$VALUE(@FGR@(0)),! ; TODO: Preserve date from ^(0)
|
||||
N I S I="" F S I=$O(@FGR@(I)) Q:I="" D:+I ; TODO: Other subscripts?
|
||||
. U IO W D,$$VALUE(@FGR@(I,0)),!
|
||||
U IO W D,";",!
|
||||
Q
|
||||
ENTITY(D,FILE,DD,EGR) ; Write a file entry
|
||||
U IO W D,"ENTITY"_$C(9)_";;"_$$FILENAME(FILE,FGR)_"^"_$S(FILE=0:"",1:FILE)_" ;"_EGR,!
|
||||
U IO W D_$C(9)_";",!
|
||||
; Add key tag with field .01 value (14.9.2).
|
||||
; TODO: Use indexing cross-references or KEY file entries for key tags?
|
||||
; TODO: Escape key values, handle pointers?
|
||||
U IO W D,"KA"_$C(9)_";;",$P(@EGR@(0),"^"),!
|
||||
U IO W D_$C(9)_";",!
|
||||
N S S S="" F S S=$O(@EGR@(S)) Q:S="" D ; Find DD fields at S.
|
||||
. I $D(DD(S))<10 D ; TODO: Field defs like "DEL" not in ^DD(0)
|
||||
. . D SUBS(D,$NA(@EGR@(S)),S)
|
||||
. N F S F="" F S F=$O(DD(S,F)) Q:F="" D
|
||||
. . D FIELD(D,FILE,F,$NA(@EGR@(S)),DD(S,F))
|
||||
Q
|
||||
;
|
||||
SUBS(D,G,S) ; Write an extraneous subscript
|
||||
U IO W D,"SUBS"_$C(9)_";;"_S,!
|
||||
I $D(@G)#10 U IO W D_$C(9),$$VALUE(@G),!
|
||||
I $D(@G)\10 U IO W D_$C(9),"; OMITTED CHILDREN",!
|
||||
U IO W D_$C(9),";",!
|
||||
Q
|
||||
FIELD(D,FILE,F,EGRF,P) ; Write a field
|
||||
; The DD field definition 0-node has ^-pieces "NAME^TYPE^" (14.9.2).
|
||||
N FD S FD=^DD(FILE,F,0)
|
||||
N NAME S NAME=$P(FD,"^",1)
|
||||
N TYPE S TYPE=$P(FD,"^",2)
|
||||
; TYPE starts with a subfile number if the field is a multiple (14.9.2)
|
||||
N SUBFILE S SUBFILE=+TYPE
|
||||
I SUBFILE D
|
||||
. D FIELDSUB
|
||||
E D
|
||||
. D FIELDONE
|
||||
Q
|
||||
FIELDTAG ; Write tag for a field
|
||||
U IO W D,"F"_$TR(F,".","P")_$C(9)_";;"_NAME_"^"_F_" ;"_TYPE,!
|
||||
Q
|
||||
FIELDSUB ; Write a multiple-valued field
|
||||
D FIELDTAG
|
||||
I $D(@EGRF)#10 U IO W D_$C(9),"; OMITTED SELF",!
|
||||
; Word-processing values are files whose .01 field type has "W".
|
||||
I $P($G(^DD(SUBFILE,.01,0)),"^",2)["W" D
|
||||
. D WP(D_$C(9),EGRF)
|
||||
E D
|
||||
. D FILE(D_$C(9),SUBFILE,EGRF) U IO W D_$C(9),";",!
|
||||
Q
|
||||
FIELDONE ; Write a single-valued field
|
||||
N V S V=$$FIELDVAL(EGRF,P) Q:V=""
|
||||
N EV ; Some TYPEs have an external-format value
|
||||
N T S T=TYPE
|
||||
I T["F" S TYPE=TYPE_";"_"Free Text"
|
||||
I T["N" S TYPE=TYPE_";"_"Numeric"
|
||||
I T["K" S TYPE=TYPE_";"_"MUMPS Code"
|
||||
I T["P" S TYPE=TYPE_";"_"Pointer",EV=1
|
||||
I T["V" S TYPE=TYPE_";"_"Variable Pointer",EV=1
|
||||
I T["S" S TYPE=TYPE_";"_"Set of Codes",EV=1
|
||||
I T["D" S TYPE=TYPE_";"_"Date",EV=1
|
||||
I $D(EV) S V=V_"^"_$$EXTERNAL^DILFD(FILE,F,"",V)
|
||||
D FIELDTAG
|
||||
U IO W D_$C(9),$$VALUE(V),!
|
||||
I $D(@EGRF)\10 U IO W D_$C(9),"; OMITTED CHILDREN",!
|
||||
U IO W D_$C(9),";",!
|
||||
Q
|
||||
FIELDVAL(EGRF,P) ; Extract piece P of node value holding field
|
||||
I +P Q $P(@EGRF,"^",P)
|
||||
I $E(P,1)="E" Q $E(@EGRF,$P($E(P,2,$L(P)),",",1),$P(P,",",2))
|
||||
Q ";UNKNOWN ""GLOBAL SUBSCRIPT LOCATION"" PIECE """_P_""""
|
||||
;
|
||||
FILENAME(FILE,FGR) ; Lookup the name of given FILE# (or subfile#)
|
||||
I FILE=0 Q $P(@FGR@(0),"^") ; DD
|
||||
Q $O(^DD(FILE,0,"NM","")) ; TODO: Reliable? Any documented API?
|
||||
VALUE(V) ; Write value line to output
|
||||
; TODO: If value starts in one of " $ ; or contains non-printing
|
||||
; characters then it must be escaped for evaluation on RHS of SET.
|
||||
; TODO: Caller must define indentation level with a comment if
|
||||
; the first character of the first value is a tab or space.
|
||||
Q V
|
||||
1864
samples/M/_zewdAPI.m
Normal file
1864
samples/M/_zewdAPI.m
Normal file
File diff suppressed because it is too large
Load Diff
256
samples/M/_zewdDemo.m
Normal file
256
samples/M/_zewdDemo.m
Normal file
@@ -0,0 +1,256 @@
|
||||
%zewdDemo ; Tutorial page functions
|
||||
;
|
||||
; Product: Enterprise Web Developer (Build 910)
|
||||
; Build Date: Wed, 25 Apr 2012 17:59:25
|
||||
;
|
||||
;
|
||||
; ----------------------------------------------------------------------------
|
||||
; | Enterprise Web Developer for GT.M and m_apache |
|
||||
; | Copyright (c) 2004-12 M/Gateway Developments Ltd, |
|
||||
; | Reigate, Surrey UK. |
|
||||
; | All rights reserved. |
|
||||
; | |
|
||||
; | http://www.mgateway.com |
|
||||
; | Email: rtweed@mgateway.com |
|
||||
; | |
|
||||
; | This program is free software: you can redistribute it and/or modify |
|
||||
; | it under the terms of the GNU Affero General Public License as |
|
||||
; | published by the Free Software Foundation, either version 3 of the |
|
||||
; | License, or (at your option) any later version. |
|
||||
; | |
|
||||
; | This program is distributed in the hope that it will be useful, |
|
||||
; | but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
||||
; | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
||||
; | GNU Affero General Public License for more details. |
|
||||
; | |
|
||||
; | You should have received a copy of the GNU Affero General Public License |
|
||||
; | along with this program. If not, see <http://www.gnu.org/licenses/>. |
|
||||
; ----------------------------------------------------------------------------
|
||||
;
|
||||
getLanguage(sessid)
|
||||
;
|
||||
s language=$$getRequestValue^%zewdAPI("ewd_Language",sessid)
|
||||
d setSessionValue^%zewdAPI("ewd_Language",language,sessid)
|
||||
d setSessionValue^%zewdAPI("url","www.mgateway.com",sessid)
|
||||
d setSessionValue^%zewdAPI("imageTest",2,sessid)
|
||||
d setSessionValue^%zewdAPI("tmp_testing",1234567,sessid)
|
||||
QUIT ""
|
||||
;
|
||||
login(sessid)
|
||||
;
|
||||
n username,password
|
||||
;
|
||||
s username=$$getTextValue^%zewdAPI("username",sessid)
|
||||
s password=$$getPasswordValue^%zewdAPI("password",sessid)
|
||||
;d trace^%zewdAPI("in login - username="_username_" ; password="_password)
|
||||
i username'="ROB" QUIT "invalid username"
|
||||
i password'="ROB" QUIT "invalid password"
|
||||
QUIT ""
|
||||
;
|
||||
logine(sessid)
|
||||
;
|
||||
n error,username,password,message,textid
|
||||
;
|
||||
s error=""
|
||||
s message=$$errorMessage^%zewdAPI("invalid login attempt",sessid)
|
||||
s username=$$getTextValue^%zewdAPI("username",sessid)
|
||||
s password=$$getPasswordValue^%zewdAPI("password",sessid)
|
||||
;
|
||||
i '$d(^ewdDemo("tutorial","authentication")) d QUIT $$errorMessage^%zewdAPI(error,sessid)
|
||||
. i username'="ROB" s error=message q
|
||||
. i password'="ROB" s error=message q
|
||||
;
|
||||
i username="" QUIT message
|
||||
i '$d(^ewdDemo("tutorial","authentication",username)) QUIT message
|
||||
i password'=$p(^ewdDemo("tutorial","authentication",username),"~",1) QUIT message
|
||||
QUIT ""
|
||||
;
|
||||
getUsernames(sessid) ;
|
||||
;
|
||||
n user
|
||||
;
|
||||
i '$d(^ewdDemo("tutorial","authentication")) d QUIT ""
|
||||
. d clearList^%zewdAPI("user",sessid)
|
||||
. d appendToList^%zewdAPI("user","Select a user..","nul",sessid)
|
||||
. d appendToList^%zewdAPI("user","ROB","ROB",sessid)
|
||||
;
|
||||
s user=""
|
||||
d clearList^%zewdAPI("user",sessid)
|
||||
d appendToList^%zewdAPI("user","Select a user..","",sessid)
|
||||
f s user=$o(^ewdDemo("tutorial","authentication",user)) q:user="" d
|
||||
. d appendToList^%zewdAPI("user",user,user,sessid)
|
||||
;
|
||||
QUIT ""
|
||||
;
|
||||
addUsername(sessid)
|
||||
;
|
||||
n newUsername
|
||||
;
|
||||
s newUsername=$$getTextValue^%zewdAPI("newUsername",sessid)
|
||||
i newUsername="" QUIT "You must enter a username"
|
||||
i $d(^ewdDemo("tutorial","authentication",newUsername)) QUIT newUsername_" already exists"
|
||||
d setTextValue^%zewdAPI("user",newUsername,sessid)
|
||||
QUIT ""
|
||||
;
|
||||
testValue(sessid)
|
||||
;
|
||||
n user,pass
|
||||
;
|
||||
s user=$$getSelectValue^%zewdAPI("user",sessid)
|
||||
;d trace^%zewdAPI("user="_user)
|
||||
QUIT ""
|
||||
;
|
||||
getPassword(sessid)
|
||||
;
|
||||
n user,pass
|
||||
;
|
||||
s user=$$getSelectValue^%zewdAPI("user",sessid)
|
||||
s pass=$g(^ewdDemo("tutorial","authentication",user))
|
||||
s pass=$p(pass,"~",1)
|
||||
i user="ROB",pass="" s pass="ROB"
|
||||
d setTextValue^%zewdAPI("pass",pass,sessid)
|
||||
QUIT ""
|
||||
;
|
||||
setPassword(sessid)
|
||||
;
|
||||
n user,pass
|
||||
;
|
||||
s user=$$getSelectValue^%zewdAPI("user",sessid)
|
||||
s pass=$$getTextValue^%zewdAPI("pass",sessid)
|
||||
i pass="" QUIT "You must enter a password"
|
||||
s ^ewdDemo("tutorial","authentication",user)=pass
|
||||
QUIT ""
|
||||
;
|
||||
getObjDetails(sessid)
|
||||
i '$$sessionNameExists^%zewdAPI("person.username",sessid) d
|
||||
. d setSessionValue^%zewdAPI("person.username","Rob",sessid)
|
||||
. d setSessionValue^%zewdAPI("person.password","secret!",sessid)
|
||||
. d setSessionValue^%zewdAPI("person.userType","g",sessid)
|
||||
. d setCheckboxOn^%zewdAPI("person.permissions","w",sessid)
|
||||
. d setCheckboxOn^%zewdAPI("person.permissions","e",sessid)
|
||||
. d clearList^%zewdAPI("person.language",sessid)
|
||||
. d appendToList^%zewdAPI("person.language","English","en",sessid)
|
||||
. d appendToList^%zewdAPI("person.language","French","fr",sessid)
|
||||
. d appendToList^%zewdAPI("person.language","German","d",sessid)
|
||||
. d appendToList^%zewdAPI("person.language","Italian","it",sessid)
|
||||
. d setMultipleSelectOn^%zewdAPI("person.language","en",sessid)
|
||||
. d setMultipleSelectOn^%zewdAPI("person.language","d",sessid)
|
||||
. d clearTextArea^%zewdAPI("person.comments",sessid)
|
||||
. s textarea(1)="This is a line of text"
|
||||
. s textarea(2)="This is the second line"
|
||||
. d createTextArea^%zewdAPI("person.comments",.textarea,sessid)
|
||||
. d setSessionValue^%zewdAPI("wld.%KEY.MGWLPN","EXTC",sessid)
|
||||
QUIT ""
|
||||
;
|
||||
setObjDetails(sessid)
|
||||
QUIT ""
|
||||
;
|
||||
getDetails(sessid)
|
||||
;
|
||||
n user,pass,data,expireDate,userType,selected,textarea,confirmText
|
||||
;
|
||||
;d trace^%zewdAPI("got here!!")
|
||||
s browser=$$getServerValue^%zewdAPI("HTTP_USER_AGENT",sessid)
|
||||
d setSessionValue^%zewdAPI("browser",browser,sessid)
|
||||
s user=$$getTextValue^%zewdAPI("user",sessid)
|
||||
s data=""
|
||||
i user'="" s data=$g(^ewdDemo("tutorial","authentication",user))
|
||||
;d trace^%zewdAPI("user="_user_" ; data="_data)
|
||||
s pass=$p(data,"~",1)
|
||||
i user="ROB",pass="" d QUIT ""
|
||||
. d setTextValue^%zewdAPI("pass","ROB",sessid)
|
||||
. d setRadioOn^%zewdAPI("userType","a",sessid)
|
||||
. d initialiseCheckbox^%zewdAPI("permissions",sessid)
|
||||
. d setCheckboxOn^%zewdAPI("permissions","w",sessid)
|
||||
. d setCheckboxOn^%zewdAPI("permissions","e",sessid)
|
||||
. d setCheckboxOn^%zewdAPI("permissions","s",sessid)
|
||||
. d createLanguageList(sessid)
|
||||
. d setMultipleSelectOn^%zewdAPI("language","en",sessid)
|
||||
. d setMultipleSelectOn^%zewdAPI("language","d",sessid)
|
||||
. d clearTextArea^%zewdAPI("comments",sessid)
|
||||
. s textarea(1)="This is a line of text"
|
||||
. s textarea(2)="This is the second line"
|
||||
. d createTextArea^%zewdAPI("comments",.textarea,sessid)
|
||||
;
|
||||
d setTextValue^%zewdAPI("pass",pass,sessid)
|
||||
;d trace^%zewdAPI("data="_data)
|
||||
s userType=$p(data,"~",2)
|
||||
i userType="" s userType="g"
|
||||
d setRadioOn^%zewdAPI("userType",userType,sessid)
|
||||
d initialiseCheckbox^%zewdAPI("permissions",sessid)
|
||||
i user'="" m selected=^ewdDemo("tutorial","authentication",user,"permissions")
|
||||
d setCheckboxValues^%zewdAPI("permissions",.selected,sessid)
|
||||
d createLanguageList(sessid)
|
||||
k selected
|
||||
i user'="" m selected=^ewdDemo("tutorial","authentication",user,"language")
|
||||
d setMultipleSelectValues^%zewdAPI("language",.selected,sessid)
|
||||
d clearTextArea^%zewdAPI("comments",sessid)
|
||||
i user'="" m textarea=^ewdDemo("tutorial","authentication",user,"comments")
|
||||
d createTextArea^%zewdAPI("comments",.textarea,sessid)
|
||||
;
|
||||
QUIT ""
|
||||
;
|
||||
createLanguageList(sessid)
|
||||
;
|
||||
n attr
|
||||
d clearList^%zewdAPI("language",sessid)
|
||||
d appendToList^%zewdAPI("language","English","en",sessid)
|
||||
s attr("style")="color:red"
|
||||
d appendToList^%zewdAPI("language","French","fr",sessid,.attr)
|
||||
d appendToList^%zewdAPI("language","German","d",sessid,.attr)
|
||||
s attr("style")="color:green"
|
||||
d appendToList^%zewdAPI("language","Italian","it",sessid,.attr)
|
||||
s attr("style")="color:green"
|
||||
d appendToList^%zewdAPI("language","Spanish","esp",sessid,.attr)
|
||||
d appendToList^%zewdAPI("language","Portuguese","por",sessid)
|
||||
d appendToList^%zewdAPI("language","Danish","den",sessid)
|
||||
d appendToList^%zewdAPI("language","Swedish","swe",sessid)
|
||||
d appendToList^%zewdAPI("language","Norwegian","nor",sessid)
|
||||
d initialiseMultipleSelect^%zewdAPI("language",sessid)
|
||||
QUIT
|
||||
;
|
||||
setDetails(sessid)
|
||||
;
|
||||
n error,expireDate,user,pass,userType,selected,comments,warning
|
||||
;
|
||||
s user=$$getTextValue^%zewdAPI("user",sessid)
|
||||
s pass=$$getTextValue^%zewdAPI("pass",sessid)
|
||||
i pass="" d QUIT "You must enter a password"
|
||||
. d setFieldError^%zewdAPI("pass",sessid)
|
||||
i pass="xxx" d setFieldError^%zewdAPI("testField",sessid) QUIT "test error"
|
||||
s userType=$$getRadioValue^%zewdAPI("userType",sessid)
|
||||
s ^ewdDemo("tutorial","authentication",user)=pass_"~"_userType
|
||||
k ^ewdDemo("tutorial","authentication",user,"permissions")
|
||||
d getCheckboxValues^%zewdAPI("permissions",.selected,sessid)
|
||||
m ^ewdDemo("tutorial","authentication",user,"permissions")=selected
|
||||
k ^ewdDemo("tutorial","authentication",user,"language")
|
||||
k selected
|
||||
d getMultipleSelectValues^%zewdAPI("language",.selected,sessid)
|
||||
m ^ewdDemo("tutorial","authentication",user,"language")=selected
|
||||
k ^ewdDemo("tutorial","authentication",user,"comments")
|
||||
d getTextArea^%zewdAPI("comments",.comments,sessid)
|
||||
m ^ewdDemo("tutorial","authentication",user,"comments")=comments
|
||||
;s warning="Record successfully updated"
|
||||
;d setWarning^%zewdAPI(warning,sessid)
|
||||
;
|
||||
QUIT ""
|
||||
;
|
||||
testAjaxForm(sessid)
|
||||
;
|
||||
i $$getRequestValue^%zewdAPI("testField1",sessid)="" d QUIT "field1 must not be null"
|
||||
. d setFieldError^%zewdAPI("testField1",sessid)
|
||||
i $$getRequestValue^%zewdAPI("testField2",sessid)="" d QUIT "javascript: x=1 ; document.getElementById('testField3').value = x"
|
||||
. d setFieldError^%zewdAPI("testField2",sessid)
|
||||
i $$getRequestValue^%zewdAPI("testField3",sessid)="" d QUIT "field3 must not be null"
|
||||
. d setFieldError^%zewdAPI("testField3",sessid)
|
||||
;
|
||||
QUIT ""
|
||||
;
|
||||
getVersion() ;
|
||||
QUIT $zv
|
||||
;
|
||||
getTime(sessid)
|
||||
;
|
||||
d setSessionValue^%zewdAPI("dateTime",$$inetDate^%zewdAPI($h),sessid)
|
||||
QUIT ""
|
||||
;
|
||||
25
samples/M/arrays.m
Normal file
25
samples/M/arrays.m
Normal file
@@ -0,0 +1,25 @@
|
||||
start ; create student data
|
||||
set student("name","first")="Linus"
|
||||
set student("name","last")="Torvalds"
|
||||
set student("language")="C"
|
||||
set student("classes","monday")="Algebra"
|
||||
set student("classes","tuesday")="Geometry"
|
||||
set student("classes","wednesday")="English"
|
||||
set student("classes","thursday")="French"
|
||||
set student("classes","friday")="Jujitsu"
|
||||
zwrite student
|
||||
write $order(student)
|
||||
|
||||
write !,"Student array top level",!
|
||||
set x=""
|
||||
for do quit:x=""
|
||||
. set x=$order(student(x))
|
||||
. write x,!
|
||||
|
||||
write !,"Student classes ",!
|
||||
set x=""
|
||||
for do quit:x=""
|
||||
. set x=$order(student("classes",x))
|
||||
. write:x'="" x," : ",student("classes",x),!
|
||||
|
||||
quit
|
||||
45
samples/M/base64.m
Normal file
45
samples/M/base64.m
Normal file
@@ -0,0 +1,45 @@
|
||||
;
|
||||
; This file is part of DataBallet.
|
||||
; Copyright (C) 2012 Laurent Parenteau <laurent.parenteau@gmail.com>
|
||||
;
|
||||
; DataBallet is free software: you can redistribute it and/or modify
|
||||
; it under the terms of the GNU Affero General Public License as
|
||||
; published by the Free Software Foundation, either version 3 of the
|
||||
; License, or (at your option) any later version.
|
||||
;
|
||||
; DataBallet is distributed in the hope that it will be useful,
|
||||
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
; GNU Affero General Public License for more details.
|
||||
;
|
||||
; You should have received a copy of the GNU Affero General Public License
|
||||
; along with DataBallet. If not, see <http://www.gnu.org/licenses/>.
|
||||
;
|
||||
|
||||
encode(message)
|
||||
;
|
||||
; Return base64 with URL and Filename safe alphabet (RFC 4648)
|
||||
;
|
||||
new base64,todrop,i
|
||||
|
||||
; Populate safe alphabet values on first use only.
|
||||
if '$data(base64safe) do
|
||||
. for i=0:1:25 set base64safe(i)=$zchar(65+i),base64safe(i+26)=$zchar(97+i)
|
||||
. for i=52:1:61 set base64safe(i)=$zchar(i-4)
|
||||
. set base64safe(62)="-",base64safe(63)="_"
|
||||
|
||||
; Pad message with 0 to ensure number of bytes is a multiple of 3.
|
||||
set todrop=0
|
||||
for quit:($zlength(message)#3)=0 set message=message_$zchar(0) set todrop=todrop+1
|
||||
|
||||
; Base64 encode the message
|
||||
set base64=""
|
||||
for i=1:3:$zlength(message) do
|
||||
. set base64=base64_base64safe($zascii(message,i)\4)
|
||||
. set base64=base64_base64safe(($zascii(message,i)#4*16)+($zascii(message,i+1)\16))
|
||||
. set base64=base64_base64safe(($zascii(message,i+1)#16*4)+($zascii(message,i+2)\64))
|
||||
. set base64=base64_base64safe($zascii(message,i+2)#64)
|
||||
|
||||
set:todrop'=0 base64=$zextract(base64,1,$zlength(base64)-todrop)
|
||||
|
||||
quit base64
|
||||
74
samples/M/digest.m
Normal file
74
samples/M/digest.m
Normal file
@@ -0,0 +1,74 @@
|
||||
;
|
||||
; GT.M Digest Extension
|
||||
; Copyright (C) 2012 Piotr Koper <piotr.koper@gmail.com>
|
||||
;
|
||||
; This program is free software: you can redistribute it and/or modify
|
||||
; it under the terms of the GNU Affero General Public License as
|
||||
; published by the Free Software Foundation, either version 3 of the
|
||||
; License, or (at your option) any later version.
|
||||
;
|
||||
; This program is distributed in the hope that it will be useful,
|
||||
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
; GNU Affero General Public License for more details.
|
||||
;
|
||||
; You should have received a copy of the GNU Affero General Public License
|
||||
; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
;
|
||||
|
||||
; GT.M™ is a trademark of Fidelity Information Services, Inc.
|
||||
|
||||
; "GT.M™ is a vetted industrial strength, transaction processing application
|
||||
; platform consisting of a key-value database engine optimized for extreme
|
||||
; transaction processing throughput & business continuity."
|
||||
; -- http://sourceforge.net/projects/fis-gtm/
|
||||
|
||||
|
||||
|
||||
; GT.M Digest Extension
|
||||
;
|
||||
; This simple OpenSSL based digest extension is a rewrite of OpenSSL
|
||||
; EVP_DigestInit usage example with additional M wrapper.
|
||||
; See http://www.openssl.org/docs/crypto/EVP_DigestInit.html for details.
|
||||
;
|
||||
; The return value from $&digest.init() is 0, usually when an invalid digest
|
||||
; algorithm was specification. Anyway, properly used, should never fail.
|
||||
;
|
||||
; Please feel free to contact me if you have any questions or comments,
|
||||
; Piotr Koper <piotr.koper@gmail.com>
|
||||
;
|
||||
|
||||
|
||||
digest(m,a) ; returns digest in ASCII HEX, all-in-one
|
||||
n c,d
|
||||
s c=$&digest.init(a)
|
||||
d &digest.update(.c,.m)
|
||||
d &digest.final(.c,.d)
|
||||
q d
|
||||
|
||||
|
||||
init(alg) ; returns context handler, for alg try "md5", "sha256", etc
|
||||
; 0 is returned when an error occurs (e.g. unknown digest)
|
||||
q $&digest.init(alg)
|
||||
|
||||
update(ctx,msg) ; updates digest (ctx) by message msg
|
||||
d &digest.update(.ctx,.msg)
|
||||
q
|
||||
|
||||
final(ctx,digest) ; returns hex encoded message digest in digest
|
||||
; frees memory allocated for the ctx also
|
||||
d &digest.final(.ctx,.digest)
|
||||
q
|
||||
|
||||
|
||||
; digest algorithms availability depends on libcrypto (OpenSSL) configuration
|
||||
|
||||
md4(m) q $$digest(.m,"md4")
|
||||
md5(m) q $$digest(.m,"md5")
|
||||
sha(m) q $$digest(.m,"sha")
|
||||
sha1(m) q $$digest(.m,"sha1")
|
||||
sha224(m) q $$digest(.m,"sha224")
|
||||
sha256(m) q $$digest(.m,"sha256")
|
||||
sha512(m) q $$digest(.m,"sha512")
|
||||
dss1(m) q $$digest(.m,"dss1")
|
||||
ripemd160(m) q $$digest(.m,"ripemd160")
|
||||
42
samples/M/dynamicscoping.m
Normal file
42
samples/M/dynamicscoping.m
Normal file
@@ -0,0 +1,42 @@
|
||||
;------------------------------------
|
||||
; These first two routines illustrate
|
||||
; the dynamic scope of variables in M
|
||||
;------------------------------------
|
||||
triangle1(x) ;;
|
||||
set sum=0
|
||||
for do quit:x'>1
|
||||
. set sum=sum+x
|
||||
. set x=x-1
|
||||
quit sum
|
||||
|
||||
main1() ;;
|
||||
set sum=1500
|
||||
set x=6
|
||||
write "sum before=",sum,!
|
||||
set y=$$triangle1(x)
|
||||
write "sum after=",sum,!
|
||||
write "triangle of ",x," is ",y,!
|
||||
quit
|
||||
|
||||
|
||||
;------------------------------------
|
||||
; These next two routines illustrate
|
||||
; the use of the NEW command to make
|
||||
; variables limited to the local scope
|
||||
;------------------------------------
|
||||
triangle2(x) ;;
|
||||
new sum ; <-- HERE !!
|
||||
set sum=0
|
||||
for do quit:x'>1
|
||||
. set sum=sum+x
|
||||
. set x=x-1
|
||||
quit sum
|
||||
|
||||
main2() ;;
|
||||
set sum=1500
|
||||
set x=6
|
||||
write "sum before=",sum,!
|
||||
set y=$$triangle2(x)
|
||||
write "sum after=",sum,!
|
||||
write "triangle of ",x," is ",y,!
|
||||
quit
|
||||
9
samples/M/fibonacci.m
Normal file
9
samples/M/fibonacci.m
Normal file
@@ -0,0 +1,9 @@
|
||||
start ; compute the Fibonacci series
|
||||
set (a,b)=1
|
||||
for i=1:1 do quit:term>100
|
||||
. set term=a+b
|
||||
. write !,term
|
||||
. set a=b
|
||||
. set b=term
|
||||
write !,"Result= ",term,!
|
||||
quit
|
||||
19
samples/M/forloop.m
Normal file
19
samples/M/forloop.m
Normal file
@@ -0,0 +1,19 @@
|
||||
start1 ; entry label
|
||||
set a=1
|
||||
set b=20
|
||||
set c=2
|
||||
set sum=0
|
||||
for i=a:c do quit:'(i<b)
|
||||
. set sum=sum+i
|
||||
. write i," : ",sum,!
|
||||
quit
|
||||
|
||||
start2 ; entry label
|
||||
set a=1
|
||||
set b=20
|
||||
set c=2
|
||||
set sum=0
|
||||
for i=a:c:b do
|
||||
. set sum=sum+i
|
||||
. write i," : ",sum,!
|
||||
quit
|
||||
19
samples/M/functions.m
Normal file
19
samples/M/functions.m
Normal file
@@ -0,0 +1,19 @@
|
||||
; This function computes a factorial
|
||||
|
||||
|
||||
factorial(n) ;;
|
||||
new f
|
||||
set f=n
|
||||
for do quit:n'>1
|
||||
. set n=n-1
|
||||
. set f=f*n
|
||||
. write n," : ",f,!
|
||||
quit f
|
||||
|
||||
|
||||
|
||||
main() ;;
|
||||
set x=5
|
||||
set y=$$factorial(x)
|
||||
write "Factorial of ",x," = ",y,!
|
||||
quit
|
||||
3
samples/M/helloworld.m
Normal file
3
samples/M/helloworld.m
Normal file
@@ -0,0 +1,3 @@
|
||||
label1 ; This is a label
|
||||
write "Hello World !",!
|
||||
quit
|
||||
35
samples/M/ifelse.m
Normal file
35
samples/M/ifelse.m
Normal file
@@ -0,0 +1,35 @@
|
||||
if1 ; simple if statement
|
||||
set a=5
|
||||
set b=10
|
||||
set c=25
|
||||
if (a<b) set c=b
|
||||
write c,!
|
||||
quit
|
||||
|
||||
if2 ; if statements contrasted
|
||||
set a=5
|
||||
set b=10
|
||||
if (a<b) write "variable a=",a," is smaller than b=",b,!
|
||||
if (a>b) write "variable a=",a," is larger than b=",b,!
|
||||
quit
|
||||
|
||||
if3 ; if statement with else clause
|
||||
set a=5
|
||||
set b=10
|
||||
if (a<b) write "variable a=",a," is smaller than b=",b,!
|
||||
else write "variable a=",a," is larger than b=",b,!
|
||||
quit
|
||||
|
||||
if4 ; if statement with else clause and bodies
|
||||
set a=5
|
||||
set b=10
|
||||
set c=10
|
||||
if (a<b) do
|
||||
. write "variable a=",a," is smaller than b=",b,!
|
||||
. set c=c+a
|
||||
else do
|
||||
. write "variable a=",a," is larger than b=",b,!
|
||||
. set c=c+b
|
||||
write "c=",c,!
|
||||
quit
|
||||
|
||||
22
samples/M/indirectfunctions.m
Normal file
22
samples/M/indirectfunctions.m
Normal file
@@ -0,0 +1,22 @@
|
||||
start ; exercise
|
||||
set ^car("make")="toyota"
|
||||
set ^car("model")="corolla"
|
||||
set ^car("mileage")="$$compute^mileage"
|
||||
|
||||
write !,"Regular computation",!
|
||||
write "make = ",^car("make"),!
|
||||
write "model = ",^car("model"),!
|
||||
write "mileage = ",@^car("mileage")@(150,4),!
|
||||
|
||||
write !,"Pesimist computation",!
|
||||
set ^car("mileage")="$$computepesimist^mileage"
|
||||
write "make = ",^car("make"),!
|
||||
write "model = ",^car("model"),!
|
||||
write "mileage = ",@^car("mileage")@(150,4),!
|
||||
|
||||
write !,"Optimist computation",!
|
||||
set ^car("mileage")="$$computeoptimist^mileage"
|
||||
write "make = ",^car("make"),!
|
||||
write "model = ",^car("model"),!
|
||||
write "mileage = ",@^car("mileage")@(150,4),!
|
||||
|
||||
76
samples/M/md5.m
Normal file
76
samples/M/md5.m
Normal file
@@ -0,0 +1,76 @@
|
||||
;
|
||||
; MD5 Implementation in M
|
||||
; Copyright (C) 2012 Piotr Koper <piotr.koper@gmail.com>
|
||||
;
|
||||
; This program is free software: you can redistribute it and/or modify
|
||||
; it under the terms of the GNU Affero General Public License as
|
||||
; published by the Free Software Foundation, either version 3 of the
|
||||
; License, or (at your option) any later version.
|
||||
;
|
||||
; This program is distributed in the hope that it will be useful,
|
||||
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
; GNU Affero General Public License for more details.
|
||||
;
|
||||
; You should have received a copy of the GNU Affero General Public License
|
||||
; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
;
|
||||
|
||||
; It works in GT.M with ZCHSET=M, but please, don't use it. It's only a joke.
|
||||
; Serves well as a reverse engineering example on obtaining boolean functions
|
||||
; from integer addition, modulo and division.
|
||||
|
||||
|
||||
md5(msg)
|
||||
; http://en.wikipedia.org/wiki/MD5
|
||||
n m,r,k,h,i,j,a,b,c,d,f,g,w,t,p,q
|
||||
s r(0)=7,r(1)=12,r(2)=17,r(3)=22,r(4)=7,r(5)=12,r(6)=17,r(7)=22,r(8)=7,r(9)=12,r(10)=17,r(11)=22,r(12)=7,r(13)=12,r(14)=17,r(15)=22,r(16)=5,r(17)=9,r(18)=14,r(19)=20,r(20)=5,r(21)=9,r(22)=14,r(23)=20,r(24)=5,r(25)=9,r(26)=14,r(27)=20,r(28)=5,r(29)=9,r(30)=14,r(31)=20,r(32)=4,r(33)=11,r(34)=16,r(35)=23,r(36)=4,r(37)=11,r(38)=16,r(39)=23,r(40)=4,r(41)=11,r(42)=16,r(43)=23,r(44)=4,r(45)=11,r(46)=16,r(47)=23,r(48)=6,r(49)=10,r(50)=15,r(51)=21,r(52)=6,r(53)=10,r(54)=15,r(55)=21,r(56)=6,r(57)=10,r(58)=15,r(59)=21,r(60)=6,r(61)=10,r(62)=15,r(63)=21
|
||||
s k(0)=3614090360,k(1)=3905402710,k(2)=606105819,k(3)=3250441966,k(4)=4118548399,k(5)=1200080426,k(6)=2821735955,k(7)=4249261313,k(8)=1770035416,k(9)=2336552879,k(10)=4294925233,k(11)=2304563134,k(12)=1804603682,k(13)=4254626195,k(14)=2792965006,k(15)=1236535329,k(16)=4129170786,k(17)=3225465664,k(18)=643717713,k(19)=3921069994,k(20)=3593408605,k(21)=38016083,k(22)=3634488961,k(23)=3889429448,k(24)=568446438,k(25)=3275163606,k(26)=4107603335,k(27)=1163531501,k(28)=2850285829,k(29)=4243563512,k(30)=1735328473,k(31)=2368359562,k(32)=4294588738,k(33)=2272392833,k(34)=1839030562,k(35)=4259657740,k(36)=2763975236,k(37)=1272893353,k(38)=4139469664,k(39)=3200236656,k(40)=681279174,k(41)=3936430074,k(42)=3572445317,k(43)=76029189,k(44)=3654602809,k(45)=3873151461,k(46)=530742520,k(47)=3299628645,k(48)=4096336452,k(49)=1126891415,k(50)=2878612391,k(51)=4237533241,k(52)=1700485571,k(53)=2399980690,k(54)=4293915773,k(55)=2240044497,k(56)=1873313359,k(57)=4264355552,k(58)=2734768916,k(59)=1309151649,k(60)=4149444226,k(61)=3174756917,k(62)=718787259,k(63)=3951481745
|
||||
s h(0)=1732584193,h(1)=4023233417,h(2)=2562383102,h(3)=271733878
|
||||
s $p(m,$c(0),(55-$l(msg))#64+1)="",m=msg_$c(128)_m_$$n64($l(msg)*8),p=1,q=0
|
||||
f q:q d
|
||||
. f j=0:1:15 s w(j)=$$read(.m,.p)
|
||||
. i w(0)<0 s q=1 q
|
||||
. s a=h(0),b=h(1),c=h(2),d=h(3)
|
||||
. f i=0:1:63 d
|
||||
.. i i<16 d
|
||||
... s f=$$or($$and(b,c),$$and($$not(b),d)),g=i
|
||||
.. e i i<32 d
|
||||
... s f=$$or($$and(d,b),$$and($$not(d),c)),g=(5*i+1)#16
|
||||
.. e i i<48 d
|
||||
... s f=$$xor($$xor(b,c),d),g=(3*i+5)#16
|
||||
.. e s f=$$xor(c,$$or(b,$$not(d))),g=(7*i)#16
|
||||
.. s t=d,d=c,c=b,b=(b+$$rotate((a+f+k(i)+w(g))#4294967296,r(i)))#4294967296,a=t
|
||||
. s h(0)=(h(0)+a)#4294967296,h(1)=(h(1)+b)#4294967296,h(2)=(h(2)+c)#4294967296,h(3)=(h(3)+d)#4294967296
|
||||
q $$n32h(h(0))_$$n32h(h(1))_$$n32h(h(2))_$$n32h(h(3))
|
||||
|
||||
not(a) ; 32bit
|
||||
q 4294967295-a
|
||||
|
||||
xor(a,b) ; 32bit
|
||||
n x,i s x=0 f i=1:1:32 s x=(x\2)+(((a+b)#2)*2147483648),a=a\2,b=b\2
|
||||
q x
|
||||
|
||||
and(a,b) ; 32bit
|
||||
n x,i s x=0 f i=1:1:32 s x=(x\2)+((((a#2)+(b#2))\2)*2147483648),a=a\2,b=b\2
|
||||
q x
|
||||
|
||||
or(a,b) ; 32bit
|
||||
q $$not($$and($$not(.a),$$not(.b)))
|
||||
|
||||
rotate(a,n) ; 32bit, rol
|
||||
n c s c=a*(2**n)
|
||||
q c#4294967296+(c\4294967296)
|
||||
|
||||
read(b,i)
|
||||
n n,j s n=0 f j=3:-1:0 s n=256*n+$a($e(b,i+j))
|
||||
s i=i+4
|
||||
q n
|
||||
|
||||
n64(n)
|
||||
n s,i f i=1:1:8 s $e(s,i)=$c(n#256),n=n\256
|
||||
q s
|
||||
|
||||
n32h(n)
|
||||
n h,s,i s h="0123456789abcdef" f i=1:2:8 s $e(s,i+1)=$e(h,n#16+1),n=n\16,$e(s,i)=$e(h,n#16+1),n=n\16
|
||||
q s
|
||||
9
samples/M/mileage.m
Normal file
9
samples/M/mileage.m
Normal file
@@ -0,0 +1,9 @@
|
||||
compute(miles,gallons)
|
||||
quit miles/gallons
|
||||
|
||||
computepesimist(miles,gallons)
|
||||
quit miles/(gallons+1)
|
||||
|
||||
computeoptimist(miles,gallons)
|
||||
quit (miles+1)/gallons
|
||||
|
||||
319
samples/M/mumtris.m
Normal file
319
samples/M/mumtris.m
Normal file
@@ -0,0 +1,319 @@
|
||||
;
|
||||
; Mumtris
|
||||
; Copyright (C) 2012 Piotr Koper <piotr.koper@gmail.com>
|
||||
;
|
||||
; This program is free software: you can redistribute it and/or modify
|
||||
; it under the terms of the GNU Affero General Public License as
|
||||
; published by the Free Software Foundation, either version 3 of the
|
||||
; License, or (at your option) any later version.
|
||||
;
|
||||
; This program is distributed in the hope that it will be useful,
|
||||
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
; GNU Affero General Public License for more details.
|
||||
;
|
||||
; You should have received a copy of the GNU Affero General Public License
|
||||
; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
;
|
||||
|
||||
; Mumtris
|
||||
; This is a tetris game in MUMPS, for GT.M, have fun.
|
||||
;
|
||||
; Resize your terminal (e.g. maximize your PuTTY window), restart GT.M so that
|
||||
; it can report true size of your terminal, and d ^mumtris.
|
||||
;
|
||||
; Try setting ansi=0 for GT.M compatible cursor positioning.
|
||||
;
|
||||
; NOTICE: Mumtris uses "active waiting" for making delays lower that 1s.
|
||||
; That means that one of your CPU will be used at 99%. It's not a bug,
|
||||
; the Mumtris and GT.M will be fully responsive. Take care when
|
||||
; running on production system ;-)
|
||||
;
|
||||
|
||||
mumtris
|
||||
n ansi,e,n,w,h,gr,fl,hl,sc,lv,lc,sb,st,ml,dh,dw,mx,my,mt,r,y,x,t10m,c,ne,i,q
|
||||
|
||||
s ansi=1 ; use (faster) ANSI CSI instead of USE $P:X=x positioning
|
||||
s w=10 ; matrix width
|
||||
s h=22 ; matrix height (see below)
|
||||
s gr=1 ; grid
|
||||
s fl=1 ; fill
|
||||
s hl=1 ; help
|
||||
s sc=0 ; score
|
||||
s lv=1 ; level
|
||||
s lc=0 ; lines cleared at current level
|
||||
s sb=70 ; step base
|
||||
s st=$$step ; current step
|
||||
s ml=3 ; move/rotate hold limit (without fall)
|
||||
|
||||
d dev ; defines dw, dh (device width, device height)
|
||||
s h=dh-2 ; comment out to disable auto height
|
||||
s mx=dw/2-(3*w/2) ; matrix left coordinate
|
||||
s my=dh/2-(h/2)-1 ; matrix top coordinate
|
||||
s mt="3 5_9 8 2_9 .2_02 /5 \2 2_ 2_2 6_/2 |8_|2_| 6_0 /2 \ /2 \|2 |2 \/5 \3 2_\_2 2_ \2 |/2 3_/0/4 Y4 \2 |2 /2 Y Y2 \2 |2 |2 | \/2 |\3_ \0\4_|2_2 /4_/|2_|_|2 /2_|2 |2_|2 |2_/4_2 >08 \/9 3 \/9 9 2 \/0" ; Mumtris
|
||||
|
||||
u $p:noecho
|
||||
u $p:escape
|
||||
d cls
|
||||
|
||||
d intro
|
||||
|
||||
d elements
|
||||
s ne=$r(e)+1 ; new element
|
||||
d change,new(),preview
|
||||
d score(),help,redraw
|
||||
|
||||
s (i,q)=0
|
||||
f q:q d
|
||||
. d pos(0,0)
|
||||
. s c=$$key
|
||||
. i c=1 d exit s q=1 q
|
||||
. s i=$s('c:0,1:i+1)
|
||||
. s:i'<ml (i,c)=0
|
||||
. i c'=3,$$fall d lock,clear,change,preview i $$new d over,exit s q=1 q ; short-circuit and in first if
|
||||
. d redraw
|
||||
q
|
||||
|
||||
key() ; 0 - timeout, 1 - exit, 2 - harddrop, 3 - other char
|
||||
n q,c,d,ex,hd
|
||||
s (q,d,ex,hd)=0
|
||||
n i
|
||||
n l s l=1
|
||||
f q:q d
|
||||
. r *c:0
|
||||
. i c<0&'d d
|
||||
.. f i=1:1:st*t10m r *c:0 q:c>-1 i $h
|
||||
. i c<0 s q=1 q
|
||||
. s d=2
|
||||
. i c=27 d q:q
|
||||
.. i $l($zb)=1 s (q,ex)=1 q
|
||||
.. s c=$a($e($zb,3))
|
||||
.. d:c=65 rotate
|
||||
.. d:c=66 fall(1)
|
||||
.. d:c=67 right
|
||||
.. d:c=68 left
|
||||
. i c=70!(c=102) s fl=fl+1#3 d preview
|
||||
. s:c=71!(c=103) gr='gr
|
||||
. i c=72!(c=104) s hl='hl d help
|
||||
. d:c=73!(c=105) rotate
|
||||
. d:c=74!(c=106) left
|
||||
. d:c=75!(c=107) fall(1)
|
||||
. d:c=76!(c=108) right
|
||||
. s:c=81!(c=113) (q,ex)=1
|
||||
. i c=32 d drop s hd=1
|
||||
q $s(ex:1,hd:2,d:3,1:0)
|
||||
|
||||
redraw
|
||||
d matrix
|
||||
d stack
|
||||
d draw(n,r,y,x)
|
||||
q
|
||||
|
||||
ticks
|
||||
n x,h,b,e,q
|
||||
s h=$h,(b,e,q)=0 f i=1:1:1000000000 r *x:0 i h'=$h s h=$h d q:q
|
||||
. i 'b s b=i
|
||||
. e s e=i,q=1
|
||||
s t10m=(e-b)\100
|
||||
q
|
||||
|
||||
change
|
||||
s n=ne
|
||||
s ne=$r(e)+1
|
||||
s x=0,y=0,r=1
|
||||
q
|
||||
|
||||
new()
|
||||
s r=1,x=w/2-2,y=1-e(n,r)
|
||||
q:$q $$collision(r,y,x) q
|
||||
|
||||
drop
|
||||
n i
|
||||
s i=0 f q:$$fall s i=i+2
|
||||
d score(i)
|
||||
q
|
||||
|
||||
rotate
|
||||
n k
|
||||
s k=r#e(n)+1
|
||||
q:$$collision(k,y,x)
|
||||
s r=k
|
||||
q
|
||||
|
||||
fall(k)
|
||||
n c
|
||||
i $$collision(r,y+1,x) q:$q 1 q
|
||||
s y=y+1
|
||||
d:$g(k) score(1)
|
||||
q:$q 0 q
|
||||
|
||||
right q:$$collision(r,y,x+1) s x=x+1 q
|
||||
left q:$$collision(r,y,x-1) s x=x-1 q
|
||||
|
||||
collision(r,y,x)
|
||||
n i,j,q
|
||||
s q=0
|
||||
f i=1:1:4 q:q f j=1:1:4 q:q s:$g(e(n,r,j,i))&($g(n(y+j,x+i))!(y+j>h!(x+i>w!(x+i<1)))) q=1
|
||||
q q
|
||||
|
||||
lock
|
||||
n i,j
|
||||
f i=1:1:4 q:q f j=1:1:4 q:q s:$g(e(n,r,j,i)) n(y+j,x+i)=1
|
||||
q
|
||||
|
||||
clear
|
||||
n c,i,j,q
|
||||
s c=0
|
||||
f j=h:-1:1 d
|
||||
. s q=0
|
||||
. f i=1:1:w i '$g(n(j,i)) s q=1 q
|
||||
. q:q
|
||||
. f i=j:-1:1 k n(i) m n(i)=n(i-1)
|
||||
. s j=j+1,c=c+1
|
||||
. d redraw
|
||||
i c d
|
||||
. d score($s(c=4:800,1:i*200-100*lv))
|
||||
. s lc=lc+c
|
||||
. i lv*10'>lc d score(,1) s lc=0
|
||||
q
|
||||
|
||||
exit
|
||||
n s
|
||||
s s=mt_"09 Piotr Koper <piotr.koper@gmail.com>09 8 h2tps:2/github.com/pkoper"
|
||||
d cls d write(.s,dh/2-3,dw/2-24) h 1 r *s:0 r *s:4
|
||||
d cls u $p:echo
|
||||
q
|
||||
|
||||
intro
|
||||
n s
|
||||
s s=mt_"9 9 8 Mumtris for GT.M0"
|
||||
d cls h 1 d write(.s,dh/2-3,dw/2-24) h 1
|
||||
d ticks
|
||||
d cls
|
||||
r s:0
|
||||
q
|
||||
|
||||
cls
|
||||
d pos(0,0,1)
|
||||
q
|
||||
|
||||
pos(y,x,c)
|
||||
i ansi d
|
||||
. ; workaround for ANSI driver: NL in some safe place (1,1)
|
||||
. w $c(27)_"[1;1f",!,$c(27)_"["_(y\1+1)_";"_(x\1+1)_"f"
|
||||
. w:$g(c) $c(27)_"[2J"
|
||||
e d
|
||||
. u $p:(x=x:y=y)
|
||||
. u:$g(c) $p:clearscreen
|
||||
q
|
||||
|
||||
over
|
||||
n s
|
||||
s s="2 8_9 9 6 8_0 /2 5_/5_4 5_3 4_3 \5_2 \3_2 2_ 9_2_0/3 \2 3_\2_2 \2 /5 \_/ 2_ \3 /3 |3 \2 \/ 2/ 2_ \_2 2_ \0\4 \_\2 \/ 2_ \|2 Y Y2 \2 3_/2 /4 |4 \3 /\2 3_/|2 | \/0 \6_2 (4_2 /2_|_|2 /\3_2 > \7_2 /\_/2 \3_2 >2_|08 \/5 \/6 \/5 \/9 \/9 \/0"
|
||||
d cls,write(.s,dh/2-3,dw/2-32) h 1 r *s:0 r *s:2
|
||||
q
|
||||
|
||||
write(s,y,x)
|
||||
n i,j,l,c,d
|
||||
d pos(y,x)
|
||||
s l=$l(s) f i=1:1:l d
|
||||
. s c=$e(s,i)
|
||||
. i c?1N d
|
||||
.. i 'c s y=y+1 d pos(y,x) q
|
||||
.. s d=$e(s,i+1) f j=1:1:c w d
|
||||
.. s i=i+1
|
||||
. e w c
|
||||
d pos(0,0)
|
||||
q
|
||||
|
||||
help
|
||||
n i,x,l,j
|
||||
s i=9 f x="MOVE: LEFT, RIGHT","TURN: UP","DROP: SPACE","","FILL: F","GRID: G","HELP: H","","QUIT: ESC, Q" d pos(dh/2-(h/2)+i,dw/2+(3*w/2+3)) d s i=i+1
|
||||
. i hl w x
|
||||
. e s l=$l(x) f j=1:1:l w " "
|
||||
q
|
||||
|
||||
fill() q $s(fl=1:"[#]",fl=2:"[+]",1:"[ ]")
|
||||
|
||||
draw(n,r,y,x,o)
|
||||
n i,j
|
||||
s x=3*x+mx+1,y=y+my
|
||||
f i=1:1:4 i y+i>my f j=1:1:4 d pos(y+i-1,3*(j-1)+x) w $s($g(e(n,r,i,j)):$$fill,$g(o):" ",1:"")
|
||||
q
|
||||
|
||||
step() q 0.85**lv*sb+(0.1*lv)
|
||||
|
||||
score(s,l)
|
||||
s:$g(s) sc=sc+s
|
||||
i $g(l) s lv=lv+l,st=$$step
|
||||
d pos(dh/2-(h/2)+2,dw/2+(3*w/2+3)) w "SCORE: ",sc
|
||||
d pos(dh/2-(h/2)+3,dw/2+(3*w/2+3)) w "LEVEL: ",lv
|
||||
q
|
||||
|
||||
preview
|
||||
d draw(ne,1,4-e(ne,1),-5,1)
|
||||
q
|
||||
|
||||
stack
|
||||
n i,j,x,y
|
||||
s x=mx+1,y=my
|
||||
f i=1:1:h f j=1:1:w i $g(n(i,j)) d pos(y+i-1,3*(j-1)+x) w $$fill
|
||||
q
|
||||
|
||||
matrix
|
||||
n i,j
|
||||
f i=0:1:h-1 d
|
||||
. d pos(my+i,mx) w "|" f j=1:1:w w $s(gr:" . ",1:" ")
|
||||
. w "|"
|
||||
d pos(my+h,mx) w "|" f j=1:1:w*3 w "~"
|
||||
w "|",!
|
||||
q
|
||||
|
||||
dev
|
||||
n x,i
|
||||
zsh "d":x
|
||||
s i="" f s i=$o(x("D",i)) q:i="" d:(x("D",i)[$p)
|
||||
. s dw=$p($p(x("D",i),"WIDTH=",2)," ",1),dh=$p($p(x("D",i),"LENG=",2)," ",1)
|
||||
q
|
||||
|
||||
elements
|
||||
; e - elements
|
||||
; e(elemId) - rotateVersions
|
||||
; e(elemId,rotateVersion) - bottom coordinate
|
||||
; e(elemId,rotateVersion,y,x) - point
|
||||
;
|
||||
s e=7
|
||||
; ____
|
||||
s e(1)=2,e(1,1)=2
|
||||
s (e(1,1,2,1),e(1,1,2,2),e(1,1,2,3),e(1,1,2,4))=1
|
||||
s (e(1,2,1,2),e(1,2,2,2),e(1,2,3,2),e(1,2,4,2))=1
|
||||
; |__
|
||||
s e(2)=4,e(2,1)=2
|
||||
s (e(2,1,1,1),e(2,1,2,1),e(2,1,2,2),e(2,1,2,3))=1
|
||||
s (e(2,2,1,2),e(2,2,1,3),e(2,2,2,2),e(2,2,3,2))=1
|
||||
s (e(2,3,2,1),e(2,3,2,2),e(2,3,2,3),e(2,3,3,3))=1
|
||||
s (e(2,4,1,2),e(2,4,2,2),e(2,4,3,1),e(2,4,3,2))=1
|
||||
; __|
|
||||
s e(3)=4,e(3,1)=2
|
||||
s (e(3,1,1,3),e(3,1,2,1),e(3,1,2,2),e(3,1,2,3))=1
|
||||
s (e(3,2,1,2),e(3,2,2,2),e(3,2,3,2),e(3,2,3,3))=1
|
||||
s (e(3,3,2,1),e(3,3,2,2),e(3,3,2,3),e(3,3,3,1))=1
|
||||
s (e(3,4,1,1),e(3,4,1,2),e(3,4,2,2),e(3,4,3,2))=1
|
||||
; ||
|
||||
s e(4)=1,e(4,1)=2
|
||||
s (e(4,1,1,1),e(4,1,1,2),e(4,1,2,1),e(4,1,2,2))=1
|
||||
; _-
|
||||
s e(5)=2,e(5,1)=3
|
||||
s (e(5,1,2,2),e(5,1,2,3),e(5,1,3,1),e(5,1,3,2))=1
|
||||
s (e(5,2,1,2),e(5,2,2,2),e(5,2,2,3),e(5,2,3,3))=1
|
||||
; _|_
|
||||
s e(6)=4,e(6,1)=2
|
||||
s (e(6,1,1,2),e(6,1,2,1),e(6,1,2,2),e(6,1,2,3))=1
|
||||
s (e(6,2,1,2),e(6,2,2,2),e(6,2,2,3),e(6,2,3,2))=1
|
||||
s (e(6,3,2,1),e(6,3,2,2),e(6,3,2,3),e(6,3,3,2))=1
|
||||
s (e(6,4,1,2),e(6,4,2,1),e(6,4,2,2),e(6,4,3,2))=1
|
||||
; -_
|
||||
s e(7)=2,e(7,1)=3
|
||||
s (e(7,1,2,1),e(7,1,2,2),e(7,1,3,2),e(7,1,3,3))=1
|
||||
s (e(7,2,1,2),e(7,2,2,1),e(7,2,2,2),e(7,2,3,1))=1
|
||||
q
|
||||
17
samples/M/nesting.m
Normal file
17
samples/M/nesting.m
Normal file
@@ -0,0 +1,17 @@
|
||||
start1 ; entry label
|
||||
set ax=1
|
||||
set bx=20
|
||||
set cx=2
|
||||
set ay=1
|
||||
set by=20
|
||||
set cy=2
|
||||
set sumx=0
|
||||
set sqrx=0
|
||||
set sumxy=0
|
||||
for x=ax:cx:bx do
|
||||
. set sumx=sumx+x
|
||||
. set sqrx=sqrx+(x*x)
|
||||
. for y=ay:cy:by do
|
||||
.. set sumxy=sumxy+(x*y)
|
||||
.. if (sumxy<100) do
|
||||
... write sumxy,!
|
||||
511
samples/M/pcre.m
Normal file
511
samples/M/pcre.m
Normal file
@@ -0,0 +1,511 @@
|
||||
;
|
||||
; GT.M PCRE Extension
|
||||
; Copyright (C) 2012 Piotr Koper <piotr.koper@gmail.com>
|
||||
;
|
||||
; This program is free software: you can redistribute it and/or modify
|
||||
; it under the terms of the GNU Affero General Public License as
|
||||
; published by the Free Software Foundation, either version 3 of the
|
||||
; License, or (at your option) any later version.
|
||||
;
|
||||
; This program is distributed in the hope that it will be useful,
|
||||
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
; GNU Affero General Public License for more details.
|
||||
;
|
||||
; You should have received a copy of the GNU Affero General Public License
|
||||
; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
;
|
||||
|
||||
; GT.M™ is a trademark of Fidelity Information Services, Inc.
|
||||
|
||||
; "GT.M™ is a vetted industrial strength, transaction processing application
|
||||
; platform consisting of a key-value database engine optimized for extreme
|
||||
; transaction processing throughput & business continuity."
|
||||
; -- http://sourceforge.net/projects/fis-gtm/
|
||||
|
||||
|
||||
|
||||
; GT.M PCRE Extension
|
||||
;
|
||||
; This extension tries to deliver the best possible PCRE interface for the
|
||||
; M world by providing a support for PCRE with M arrays, stringified parameter
|
||||
; names, simplified API, locales, exceptions and Perl5 Global Match.
|
||||
;
|
||||
; See pcreexamples.m for comprehensive examples on ^pcre routines usage and
|
||||
; beginner level tips on match limits, exception handling and UTF-8 in GT.M.
|
||||
;
|
||||
; Try out the best known book on regular expressions: http://regex.info/
|
||||
; For more information on PCRE see: http://pcre.org/
|
||||
;
|
||||
; Please feel free to contact me if you have any questions or comments,
|
||||
; Piotr Koper <piotr.koper@gmail.com>
|
||||
;
|
||||
|
||||
|
||||
pcre ;GT.M PCRE Extension
|
||||
;1.0;Initial release;pkoper
|
||||
q
|
||||
|
||||
|
||||
version()
|
||||
q $&pcre.version()
|
||||
|
||||
config(name)
|
||||
; name is one of: (case insensitive)
|
||||
; "UTF8", "NEWLINE", "LINK_SIZE", "POSIX_MALLOC_THRESHOLD",
|
||||
; "MATCH_LIMIT", "MATCH_LIMIT_RECURSION", "STACKRECURSE",
|
||||
; "BSR", "UNICODE_PROPERTIES", "JIT", "JITTARGET"
|
||||
;
|
||||
d protect
|
||||
;
|
||||
n erropt,isstring,s,n,code
|
||||
s code=$&pcre.config(.name,.erropt,.isstring,.s,.n)
|
||||
s:code $ec=",U"_(-code)_","
|
||||
q $s(isstring:s,1:n)
|
||||
|
||||
compile(pattern,options,locale,mlimit,reclimit)
|
||||
; options is case insensitive and optional string with "|" joined:
|
||||
; "ANCHORED", "CASELESS", "DOLLAR_ENDONLY", "DOTALL", "EXTENDED",
|
||||
; "FIRSTLINE", "MULTILINE", "NO_AUTO_CAPTURE", "DUPNAMES",
|
||||
; "UNGREEDY", "BSR_ANYCRLF", "BSR_UNICODE", "JAVASCRIPT_COMPAT",
|
||||
; "NL_ANY", "NL_ANYCRLF", "NL_CR", "NL_CRLF","NL_LF",
|
||||
; "UTF8", "UCP", "NO_UTF8_CHECK"
|
||||
;
|
||||
; locale is an optional Unix locale name used for pcre_maketables(),
|
||||
; cases:
|
||||
; undefined or "":
|
||||
; pcre_maketables() will not be called
|
||||
; "ENV" (case insensitive):
|
||||
; use locale in program environment defined by the
|
||||
; environment variables LANG or LC_*
|
||||
; specified:
|
||||
; "pl_PL.iso88592", "pl_PL.utf8", "C", ...
|
||||
; see locale(1), locale(2) and the output of command:
|
||||
; $ locale -a
|
||||
; Debian tip: use
|
||||
; $ dpkg-reconfigure locales
|
||||
; to enable or set system-wide locale
|
||||
;
|
||||
; mlimit (optional) limits the number of internal matching function
|
||||
; calls in pcre_exec() execution, see PCRE manual for details
|
||||
;
|
||||
; reclimit (optional) limit for the depth of recursion when calling
|
||||
; the internal matching function in a pcre_exec() execution,
|
||||
; see PCRE manual for details
|
||||
;
|
||||
d protect
|
||||
;
|
||||
n erropt,ref,err,erroffset,code
|
||||
s code=$&pcre.compile(.pattern,$g(options),.erropt,.ref,.err,.erroffset,$g(locale),$g(mlimit,0),$g(reclimit,0))
|
||||
s:code $ec=",U"_(-code)_","
|
||||
q ref
|
||||
|
||||
exec(ref,subject,options,startoffset,length)
|
||||
; options is case insensitive and optional string with "|" joined:
|
||||
; "ANCHORED", "BSR_ANYCRLF", "BSR_UNICODE",
|
||||
; "NL_ANY", "NL_ANYCRLF", "NL_CR", "NL_CRLF", "NL_LF",
|
||||
; "NOTBOL", "NOTEOL", "NOTEMPTY", "NOTEMPTY_ATSTART",
|
||||
; "NO_START_OPTIMIZE", "NO_UTF8_CHECK",
|
||||
; "PARTIAL_SOFT", "PARTIAL_HARD"
|
||||
;
|
||||
; startoffset is in octets, starts with 1 (like in M) (optional)
|
||||
;
|
||||
; length is subject length in octets, not chars (optional)
|
||||
;
|
||||
d protect
|
||||
;
|
||||
n erropt,code,start
|
||||
s start=$g(startoffset,1)-1
|
||||
s code=$&pcre.exec(.ref,.subject,$g(length,$zl(subject)),start,$g(options),.erropt)
|
||||
s:code<0 $ec=",U"_(-code)_","
|
||||
q code
|
||||
|
||||
ovector(ref,i) ; return i-element from ovector
|
||||
d protect
|
||||
;
|
||||
n n,code
|
||||
s code=$&pcre.ovector(.ref,.i,.n)
|
||||
s:code $ec=",U"_(-code)_","
|
||||
;s $ec=",U123,"
|
||||
q n
|
||||
|
||||
ovecsize(ref) ; return ovecsize
|
||||
d protect
|
||||
;
|
||||
n n,code
|
||||
s code=$&pcre.ovecsize(.ref,.n)
|
||||
s:code $ec=",U"_(-code)_","
|
||||
q n
|
||||
|
||||
fullinfo(ref,name)
|
||||
; name is one of: (case insensitive)
|
||||
; "OPTIONS", "SIZE", "CAPTURECOUNT", "BACKREFMAX", "FIRSTBYTE",
|
||||
; "FIRSTTABLE", "LASTLITERAL", "NAMEENTRYSIZE", "NAMECOUNT",
|
||||
; "STUDYSIZE", "OKPARTIAL", "JCHANGED", "HASCRORLF", "MINLENGTH",
|
||||
; "JIT", "JITSIZE"
|
||||
; for NAME* options see also $$nametable^pcre()
|
||||
;
|
||||
d protect
|
||||
;
|
||||
n erropt,isstring,s,n,code
|
||||
s code=$&pcre.fullinfo(.ref,.name,.erropt,.isstring,.s,.n)
|
||||
s:code $ec=",U"_(-code)_","
|
||||
q $s(isstring:s,1:n)
|
||||
|
||||
nametable(ref,i,n) ; returns index (n) and name, or { 0, "" } for invalid i
|
||||
; i is indexed from 1
|
||||
;
|
||||
d protect
|
||||
;
|
||||
n s,code
|
||||
s code=$&pcre.nametable(.ref,.i,.n,.s)
|
||||
s:code $ec=",U"_(-code)_","
|
||||
q s
|
||||
|
||||
substring(ref,i,begin,end)
|
||||
s begin=$$ovector(.ref,i*2)+1,end=$$ovector(.ref,i*2+1)
|
||||
; ovector contains octet indexed data not UNICODE chars, so $ze is used
|
||||
q:'begin ""
|
||||
q $s($g(o,0):begin_","_end,1:$ze(subject,begin,end))
|
||||
|
||||
store(ref,i,n,o,key) ; same as above but stores captured data in n array
|
||||
n begin,end
|
||||
s begin=$$ovector(.ref,i*2)+1,end=$$ovector(.ref,i*2+1)
|
||||
q:'begin
|
||||
s key=$g(key,i)
|
||||
s:o n(key,0)=begin,n(key,1)=end
|
||||
s n(key)=$ze(subject,begin,end)
|
||||
q
|
||||
|
||||
gstore(ref,i,n,round,byref,o,key) ; store for global match
|
||||
n begin,end
|
||||
s begin=$$ovector(.ref,i*2)+1,end=$$ovector(.ref,i*2+1)
|
||||
q:'begin
|
||||
s key=$g(key,i)
|
||||
i byref d
|
||||
. s:o n(key,round,0)=begin,n(key,round,1)=end
|
||||
. s n(key,round)=$ze(subject,begin,end)
|
||||
e d
|
||||
. s:o n(round,key,0)=begin,n(round,key,1)=end
|
||||
. s n(round,key)=$ze(subject,begin,end)
|
||||
q
|
||||
|
||||
test(subject,pattern,options,locale,mlimit,reclimit)
|
||||
; see $$compile^pcre for options, locale, mlimit and reclimit
|
||||
;
|
||||
d protect
|
||||
n ref,l
|
||||
s ref=$$compile(.pattern,$g(options),$g(locale),$g(mlimit,0),$g(reclimit,0))
|
||||
s l=$$exec(.ref,.subject)
|
||||
d free(.ref)
|
||||
q l
|
||||
|
||||
match(subject,pattern,match,capture,options,locale,mlimit,reclimit)
|
||||
; see $$compile^pcre for options, locale, mlimit and reclimit
|
||||
;
|
||||
; capture is case insensitive and optional string with "|" joined
|
||||
; names or indexes to be capture
|
||||
;
|
||||
; extended options:
|
||||
; "NAMED_ONLY" - capture only named groups
|
||||
; "OVECTOR" - return additional ovector data
|
||||
;
|
||||
d protect
|
||||
;
|
||||
n namedonly,ovector,ref,o,l,i,j,s,c,begin
|
||||
;
|
||||
s options=$g(options),(namedonly,ovector)=0
|
||||
f i=1:1:$l(options,"|") d
|
||||
. s o=$zco($p(options,"|",i),"u")
|
||||
. i o="NAMED_ONLY" s namedonly=1,$p(options,"|",i)=""
|
||||
. i o="OVECTOR" s ovector=1,$p(options,"|",i)=""
|
||||
s:namedonly options=options_"|NO_AUTO_CAPTURE"
|
||||
;
|
||||
k match
|
||||
s ref=$$compile(.pattern,.options,$g(locale),$g(mlimit,0),$g(reclimit,0))
|
||||
s l=$$exec(.ref,.subject)
|
||||
i $d(capture) d
|
||||
. s c="|"_capture_"|"
|
||||
. ; ovector indexed data
|
||||
. i 'namedonly f i=0:1:l-1 d:c[("|"_i_"|") store(.ref,.i,.match,.ovector)
|
||||
. ; named matches data
|
||||
. f i=1:1 s s=$$nametable(.ref,.i,.j) q:s="" d:c[("|"_s_"|") store(.ref,.j,.match,.ovector,.s)
|
||||
e d
|
||||
. i 'namedonly f i=0:1:l-1 d store(.ref,.i,.match,.ovector)
|
||||
. f i=1:1 s s=$$nametable(.ref,.i,.j) q:s="" d store(.ref,.j,.match,.ovector,.s)
|
||||
d free(.ref)
|
||||
q:$q l q
|
||||
|
||||
global(subject,pattern,match,capture,options,locale,mlimit,reclimit)
|
||||
; options is the same as for match^pcre, extended options:
|
||||
; "OVECTOR" - return additional ovector data
|
||||
; "GROUPED" - group the result in match array by pattern groups
|
||||
; "NAMED_ONLY" - capture only named patterns
|
||||
;
|
||||
; see pcredemo.c and pcreccp.cc from PCRE for comments on procedure
|
||||
; for Perl like global matching
|
||||
;
|
||||
d protect
|
||||
;
|
||||
n ref,c,o,ovector,byref,namedonly,utf8,crlf,start,end,matches,empty,skip,round,i,j,s,n,q
|
||||
k match
|
||||
;
|
||||
; determine additional options and remove them before calling the compile^pcre
|
||||
s options=$g(options),(ovector,byref,namedonly)=0
|
||||
f i=1:1:$l(options,"|") d
|
||||
. s o=$zco($p(options,"|",i),"u")
|
||||
. i o="NAMED_ONLY" s namedonly=1,$p(options,"|",i)=""
|
||||
. i o="GROUPED" s byref=1,$p(options,"|",i)=""
|
||||
. i o="OVECTOR" s ovector=1,$p(options,"|",i)=""
|
||||
s:namedonly options=options_"|NO_AUTO_CAPTURE"
|
||||
;
|
||||
; compile the pattern
|
||||
s ref=$$compile(.pattern,.options,$g(locale),$g(mlimit,0),$g(reclimit,0))
|
||||
;
|
||||
s:$d(capture) c="|"_capture_"|"
|
||||
s byref=$g(byref,0)
|
||||
;
|
||||
; check pattern options for UTF8 and double char new line
|
||||
s o="|"_$$fullinfo(.ref,"OPTIONS")_"|"
|
||||
s utf8=$s(o["|UTF8|":1,1:0)
|
||||
s crlf=$s(o["|NL_CRLF|":1,o["|NL_ANY|":1,o["|NL_ANYCRLF|":1,1:0)
|
||||
;
|
||||
; if none check the PCRE build options
|
||||
i crlf=0 d
|
||||
. s o=$$config("NEWLINE")
|
||||
. s crlf=$s(o="NL_CRLF":1,o="NL_ANY":1,o="NL_ANYCRLF":1,1:0)
|
||||
;
|
||||
s (start,round,i)=1,(empty,skip,q)=0
|
||||
s end=$l(subject)+1
|
||||
f d q:start>end!q
|
||||
. i empty d
|
||||
.. s matches=$$exec(.ref,.subject,"NOTEMPTY_ATSTART|ANCHORED",.start) ; unwind this call to optimize
|
||||
.. q:matches ; quit this do, leave empty=1, store the matches
|
||||
..
|
||||
.. ; advance if no match & clear empty
|
||||
.. s start=start+1
|
||||
.. i start>end s q=1 q
|
||||
..
|
||||
.. ; skip LF if CR was before and CRLF mode
|
||||
.. s:crlf&(($ze(subject,start-1)=$c(13))&($ze(subject,start)=$c(10))) start=start+1
|
||||
..
|
||||
.. ; skip if in a middle of UTF char
|
||||
.. i utf8 f q:start'<end!($zbitand($c(0)_$ze(subject,start),$c(0)_$c(192))=$c(0)_$c(128)) s start=start+1
|
||||
..
|
||||
.. ; take into account skipped chars
|
||||
.. s skip=1,empty=0
|
||||
. e d
|
||||
.. s matches=$$exec(.ref,.subject,,.start)
|
||||
.. i 'matches s q=1 q
|
||||
.
|
||||
. q:q
|
||||
. i skip s skip=0 q
|
||||
.
|
||||
. i $d(c) d
|
||||
.. ; ovector indexed data
|
||||
.. i 'namedonly f i=0:1:matches-1 d:c[("|"_i_"|") gstore(.ref,.i,.match,.round,.byref,.ovector)
|
||||
.. ; named matches data
|
||||
.. f i=1:1 s s=$$nametable(.ref,.i,.n) q:s="" d:c[("|"_s_"|") gstore(.ref,.n,.match,.round,.byref,.ovector,.s)
|
||||
. e d
|
||||
.. i 'namedonly f i=0:1:matches-1 d gstore(.ref,.i,.match,.round,.byref,.ovector)
|
||||
.. f i=1:1 s s=$$nametable(.ref,.i,.n) q:s="" d gstore(.ref,.n,.match,.round,.byref,.ovector,.s)
|
||||
. s round=round+1
|
||||
.
|
||||
. s start=$$ovector(.ref,1)+1
|
||||
. s empty=(($$ovector(.ref,0)+1)=start)
|
||||
d free(.ref)
|
||||
q:$q round-1 q
|
||||
|
||||
|
||||
replace(subject,pattern,subst,first,last,options,locale,mlimit,reclimit)
|
||||
; see $$match^pcre and $$compile^pcre for options, locale, mlimit and
|
||||
; reclimit
|
||||
;
|
||||
; subst is a string to replace with all occurrences of matched data
|
||||
; \n (like \1, \2, ..) is a back ref for the n-th captured group
|
||||
; \{name} is back ref for a named captured data
|
||||
; \\ is replaced with \
|
||||
;
|
||||
; first is the n-th match in the subject where the substitution begins,
|
||||
; 1 .. n-1 matches are not substituted
|
||||
; defaults to 1
|
||||
;
|
||||
; last is the n-th match in the subject where the substitution ends,
|
||||
; n+1 .. matches are not substituted
|
||||
; defaults to 0 (no limit)
|
||||
;
|
||||
n ref,o,n,i,j,begin,end,offset,backref,boffset,value,s
|
||||
s ref=$$compile(.pattern,,$g(locale),$g(mlimit,0),$g(reclimit,0))
|
||||
;
|
||||
; prepare back reference stack
|
||||
d global^pcre(.subst,"\\(?:(?<ref>(?:\d+|\\))|{(?<ref>[^}]+)})",.backref,,"ovector|dupnames")
|
||||
;
|
||||
s options=$g(options)_"|ovector"
|
||||
; silently remove "NAMED_ONLY" and "GROUPPED" options
|
||||
f i=1:1:$l(options,"|") d
|
||||
. s o=$zco($p(options,"|",i),"u")
|
||||
. s:o="NAMED_ONLY"!(o="GROUPED") $p(options,"|",i)=""
|
||||
q:'$$global(.subject,.pattern,.n,,.options,$g(locale),$g(mlimit,0),$g(reclimit,0)) subject
|
||||
;
|
||||
; perform the substitution on matched subject parts
|
||||
s first=$g(first,1),last=$g(last,0)
|
||||
s offset=0,i=""
|
||||
f s i=$o(n(i)) q:i="" d:i'<first q:last>0&(i'<last)
|
||||
.
|
||||
. ; replace back refs in subst (s) with captured data
|
||||
. s s=subst,boffset=0,j=""
|
||||
. f s j=$o(backref(j)) q:j="" d
|
||||
..
|
||||
.. ; determine the back ref type and get the value
|
||||
.. ; silently ignore invalid refs
|
||||
.. s value=$s(backref(j,"ref")="\":"\\",1:$g(n(i,backref(j,"ref"))))
|
||||
..
|
||||
.. ; replace back ref with the value
|
||||
.. s begin=backref(j,0,0)
|
||||
.. s end=backref(j,0,1)
|
||||
.. s $ze(s,begin+boffset,end+boffset)=value
|
||||
.. s boffset=boffset-(end+1-begin)+$l(value)
|
||||
.
|
||||
. ; replace matched data with prepared s
|
||||
. s begin=n(i,0,0)
|
||||
. s end=n(i,0,1)
|
||||
.
|
||||
. s $ze(subject,begin+offset,end+offset)=s
|
||||
.
|
||||
. ; substitute empty matches also (Perl style)
|
||||
. ;
|
||||
. ; perl -e '$_ = "aa"; s/(b*|a)/Xy/g; print "$_\n"'
|
||||
. ; w $$replace^pcre("aa","(b*|a)","Xy")
|
||||
. ;
|
||||
. ; perl -e '$_ = "aa"; s/(b*|aa)/Xy/g; print "$_\n"'
|
||||
. ; w $$replace^pcre("aa","(b*|aa)","Xy")
|
||||
. ;
|
||||
. ; perl -e '$_ = "aaa"; s/(b*|aa)/Xy/g; print "$_\n"'
|
||||
. ; w $$replace^pcre("aaa","(b*|aa)","Xy")
|
||||
. ;
|
||||
. s:begin>end $ze(subject,begin+offset,begin+offset+1)=s_$ze(subject,begin+offset,begin+offset+1)
|
||||
.
|
||||
. s offset=offset-(end+1-begin)+$l(s)
|
||||
q:$q subject q
|
||||
|
||||
free(ref)
|
||||
d protect
|
||||
n code
|
||||
s code=$&pcre.free(.ref)
|
||||
s:code $ec=",U"_(-code)_","
|
||||
q
|
||||
|
||||
stackusage()
|
||||
; return the approximate amount of stack (in bytes) used per
|
||||
; recursion in pcre_exec()
|
||||
q -$&pcre.stackusage()
|
||||
|
||||
|
||||
; Exception Handling
|
||||
;
|
||||
; Error conditions are handled by setting the $zc to user codes, see labels
|
||||
; at the end of this file. When neither $zt nor $et are set by the user,
|
||||
; the default handler (trap^pcre) is used within $zt mechanism.
|
||||
;
|
||||
; The default handler will write out the details of the exception, and
|
||||
; depending on the caller type, it will re raise the exception. This will
|
||||
; lead to:
|
||||
; a) writing the exception details, when called from the GT.M prompt,
|
||||
; b) writing the exception details, the M code place when the pcre routine
|
||||
; was called, and terminating the GT.M image.
|
||||
;
|
||||
; The user should define own exception handler using $zt or $et, see
|
||||
; pcreexample.m for example exception handlers.
|
||||
;
|
||||
|
||||
protect ; try setup $zt with default handler
|
||||
;
|
||||
; "n protect" in the $zt is a marker for trap^pcre
|
||||
s:'$l($et)&(($zt="B")!'$l($zt)) $zt="n protect d trap zg "_($zl-2)
|
||||
q
|
||||
|
||||
trap(stack)
|
||||
; see U* labels at the bottom of this file, some lvns are mandatory
|
||||
; all exceptions are passed through if we wasn't called from direct mode
|
||||
;
|
||||
n zl,ref,msg,place
|
||||
;
|
||||
; take the $zl if in default handler setup by protect^trap
|
||||
s zl=$p($zt,"n protect d trap zg ",2)
|
||||
;
|
||||
; clear the $zt
|
||||
s $zt=""
|
||||
;
|
||||
; source location from either stack argument, zl (default handler), or $st-2
|
||||
s place=$st($g(stack,$g(zl,$st-1)-1),"PLACE")
|
||||
;
|
||||
; clear location if called from direct mode
|
||||
s:place["^GTM$DMOD" place=""
|
||||
;
|
||||
s ref=$p($ec,",",$l($ec,",")-1)
|
||||
i $l($t(@ref)) d
|
||||
. u $p
|
||||
. w @$p($t(@ref),";",2)
|
||||
. ; %PCRE-E-COMPILE additional message
|
||||
. w:ref="U16392"&$g(erroffset) " in "_$e($g(pattern),1,erroffset)_" <-- HERE"
|
||||
. w !
|
||||
. ; write the location it has any meaning
|
||||
. w:$l(place) "%PCRE-I-RTSLOC, At M source location ",place,!
|
||||
e d
|
||||
. w $p($zs,",",3,4),!
|
||||
. w "%GTM-I-RTSLOC, At M source location ",$p($zs,",",2),!
|
||||
;
|
||||
; re raise the exception if in a default handler and not called from the direct mode
|
||||
s:$l(place)&$g(zl,0) $ec=$ec
|
||||
q
|
||||
|
||||
; XC API specific
|
||||
;
|
||||
U16384 ;"%PCRE-E-ARGSMALL, Actual argument count is too small"
|
||||
U16385 ;"%PCRE-E-OPTNAME, Unknown option name "_$p($g(erropt),"|")
|
||||
U16386 ;"%PCRE-E-OBJLIMIT, Maximum number of objects exceeded"
|
||||
U16387 ;"%PCRE-E-INVREF, Invalid object reference"
|
||||
U16388 ;"%PCRE-E-INTBUF, Internal buffer too small"
|
||||
U16389 ;"%PCRE-E-MALLOC, Could not allocate memory"
|
||||
U16390 ;"%PCRE-E-STUDY, Pattern study failed: "_$g(err,"unknown reason")
|
||||
U16391 ;"%PCRE-E-LOCALE, Invalid locale name "_$g(locale)
|
||||
U16392 ;"%PCRE-E-COMPILE, Pattern compilation failed, "_$g(err,"unknown reason")
|
||||
U16393 ;"%PCRE-E-LENGTH, Invalid length value specified"
|
||||
|
||||
; PCRE specific
|
||||
;
|
||||
; NOTES:
|
||||
;
|
||||
; U16401 exception is never raised; when pcre_exec() returns -1
|
||||
; (i.e. NOMATCH) the pcre.exec returns 0, so no exception will
|
||||
; ever raise, NOMATCH is not an uncommon situation
|
||||
;
|
||||
; U16388 is raised when pcre_exec() returns 0, i.e. the ovector
|
||||
; was too small; considering that ovector size is not controlled
|
||||
; in M world, it is an exception here
|
||||
;
|
||||
U16401 ;"%PCRE-E-NOMATCH, The subject string did not match the pattern"
|
||||
U16402 ;"%PCRE-E-NULL, Either compiled code or subject was passed as NULL, or ovector was NULL"
|
||||
U16403 ;"%PCRE-E-BADOPTION, An unrecognized bit was set in the options argument"
|
||||
U16404 ;"%PCRE-E-BADMAGIC, The magic number is not present in compiled code"
|
||||
U16405 ;"%PCRE-E-UNKNOWNOPCODE, While running the pattern match, an unknown item was encountered in the compiled pattern"
|
||||
U16406 ;"%PCRE-E-NOMEMORY, Call via pcre_malloc() or pcre_stack_malloc() failed"
|
||||
U16407 ;"%PCRE-E-NOSUBSTRING, No substring"
|
||||
U16408 ;"%PCRE-E-MATCHLIMIT, Match limit was reached"
|
||||
U16409 ;"%PCRE-E-CALLOUT, Callout function wanted to yield a distinctive error code"
|
||||
U16410 ;"%PCRE-E-BADUTF8, A string that contains an invalid UTF-8 byte sequence was passed as a subject"
|
||||
U16411 ;"%PCRE-E-BADUTF8OFFSET, The value of startoffset did not point to the beginning of a UTF-8 character or the end of the subject"
|
||||
U16412 ;"%PCRE-E-PARTIAL, The subject string did not match, but it did match partially"
|
||||
U16414 ;"%PCRE-E-INTERNAL, An unexpected internal error has occurred"
|
||||
U16415 ;"%PCRE-E-BADCOUNT, The value of the ovecsize argument is negative"
|
||||
U16416 ;"%PCRE-E-DFAUITEM, Unsupported item in the pattern, for e.g. \C o a back reference"
|
||||
U16417 ;"%PCRE-E-DFAUCOND, Unsupported condition item, for e.g. a back reference for a condition, or a test for recursion in a specific group"
|
||||
U16418 ;"%PCRE-E-DFAUMLIMIT, Match limits are unsupported for DTA matching"
|
||||
U16419 ;"%PCRE-E-DFAWSSIZE, Out of space in the workspace vector"
|
||||
U16420 ;"%PCRE-E-DFARECURSE, The output vector was not large enough while processing recursive subpattern"
|
||||
U16421 ;"%PCRE-E-RECURSIONLIMIT, The internal recursion limit was reached"
|
||||
U16423 ;"%PCRE-E-BADNEWLINE, An invalid combination of NL_xxx options was given"
|
||||
U16424 ;"%PCRE-E-BADOFFSET, The startoffset was negative or greater than the length of the value in length"
|
||||
U16425 ;"%PCRE-E-SHORTUTF8, The subject string ends with a truncated UTF-8 character and the PCRE_PARTIAL_HARD option is set"
|
||||
U16426 ;"%PCRE-E-RECURSELOOP, A recursion loop within the pattern was detected"
|
||||
U16427 ;"%PCRE-E-JITSTACKLIMIT, The memory available for the just-in-time processing stack is not large enough"
|
||||
622
samples/M/pcreexamples.m
Normal file
622
samples/M/pcreexamples.m
Normal file
@@ -0,0 +1,622 @@
|
||||
;
|
||||
; GT.M PCRE Extension
|
||||
; Copyright (C) 2012 Piotr Koper <piotr.koper@gmail.com>
|
||||
;
|
||||
; This program is free software: you can redistribute it and/or modify
|
||||
; it under the terms of the GNU Affero General Public License as
|
||||
; published by the Free Software Foundation, either version 3 of the
|
||||
; License, or (at your option) any later version.
|
||||
;
|
||||
; This program is distributed in the hope that it will be useful,
|
||||
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
; GNU Affero General Public License for more details.
|
||||
;
|
||||
; You should have received a copy of the GNU Affero General Public License
|
||||
; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
||||
;
|
||||
|
||||
|
||||
|
||||
; GT.M PCRE Extension Examples
|
||||
;
|
||||
; see pcre.m for comments on routines parameters and all possible values for
|
||||
; the options
|
||||
;
|
||||
pcreexamples ;GT.M PCRE Extension Examples
|
||||
;1.0;Initial release;pkoper
|
||||
d routines
|
||||
q
|
||||
|
||||
|
||||
; GT.M PCRE Extension API
|
||||
; The shining examples
|
||||
;
|
||||
|
||||
test
|
||||
; Test the subject for the match
|
||||
w $$test^pcre("The quick brown fox jumps over the lazy dog","fox"),!
|
||||
w $$test^pcre("The quick brown fox jumps over the lazy dog","FoX","caseless"),!
|
||||
q
|
||||
|
||||
match
|
||||
n n
|
||||
; Simple match
|
||||
w $$match^pcre("The quick brown fox jumps over the lazy dog"," (\w+) ",.n),! zwr
|
||||
|
||||
; Match with a named groups
|
||||
w $$match^pcre("The quick brown fox jumps over the lazy dog","(?<first>\w+) (?<second>\w+)",.n),! zwr
|
||||
|
||||
; Match with a named group and limit the output to only the "second"
|
||||
w $$match^pcre("The quick brown fox jumps over the lazy dog","(?<first>\w+) (?<second>\w+)",.n,"second"),! zwr
|
||||
|
||||
; Match with a named group with only named patterns
|
||||
w $$match^pcre("The quick brown fox jumps over the lazy dog","(?<first>\w+) (?<second>\w+)",.n,,"named_only"),! zwr
|
||||
q
|
||||
|
||||
global
|
||||
n n
|
||||
; Global match
|
||||
w $$global^pcre("The quick brown fox jumps over the lazy dog","(\w+)",.n),! zwr
|
||||
|
||||
; Global match with a named groups
|
||||
w $$global^pcre("The quick brown fox jumps over the lazy dog","(?<first>\w+)\s+(?<second>\w+)",.n),! zwr
|
||||
|
||||
; Global match with grouped captured data
|
||||
w $$global^pcre("The quick brown fox jumps over the lazy dog","(?<first>\w+)\s+(?<second>\w+)",.n,,"grouped"),! zwr
|
||||
|
||||
; Global match with grouped captured data and only named patterns
|
||||
w $$global^pcre("The quick brown fox jumps over the lazy dog","(?<first>\w+)\s+(?<second>\w+)",.n,,"grouped|named_only"),! zwr
|
||||
q
|
||||
|
||||
replace
|
||||
; Just the replace
|
||||
w $$replace^pcre("The quick brown fox jumps over the lazy dog","brown","yellow"),!
|
||||
|
||||
; Change the word order
|
||||
w $$replace^pcre("The quick brown fox jumps over the lazy dog","(\w+)\s+(\w+)","\2 \1"),!
|
||||
|
||||
; Change the word order with named groups
|
||||
w $$replace^pcre("The quick brown fox jumps over the lazy dog","(?<first>\w+)\s+(?<second>\w+)","\{second} \{first}"),!
|
||||
|
||||
; Escape the \ sequence
|
||||
w $$replace^pcre("The quick brown fox jumps over the lazy dog","(?<first>\w+)\s+(?<second>\w+)","\{second} \\{first}"),!
|
||||
|
||||
; More \ chars
|
||||
w $$replace^pcre("The quick brown fox jumps over the lazy dog","(?<first>\w+)\s+(?<second>\w+)","\\\{second} \\\\{first}"),!
|
||||
q
|
||||
|
||||
|
||||
|
||||
; PCRE API
|
||||
; Low level PCRE API examples
|
||||
;
|
||||
api
|
||||
n subject,pattern,options,offset,ref,count,i,begin,end,s,name,n
|
||||
|
||||
; Setup exception trap as in myexception2^pcreexamples
|
||||
s $zt="d trap^pcre("_$st_") zg "_$zl_":apitrap^pcreexamples"
|
||||
|
||||
s subject="The quick brown fox "_$c(10)_"jumps over the lazy dog"
|
||||
s pattern="(?<all>(.*?(?<red>F\S+).*?)(?<high>\w+))"
|
||||
|
||||
; options are case insensitive, as well as all stringified option
|
||||
; names for all functions in this extension
|
||||
s options="CASELESS|multiLINE|NL_CrLf|NO_AUTO_CAPTURE|dotall"
|
||||
s offset=5 ; start the match with "quick"
|
||||
|
||||
; Compile the pattern
|
||||
s ref=$$compile^pcre(.pattern,.options) ; pass by the reference
|
||||
|
||||
; Run the match
|
||||
s count=$$exec^pcre(.ref,.subject,,.offset)
|
||||
w "count: ",count,!
|
||||
|
||||
; To access the ovector array $$ovector^pcre and $$ovecsize^pcre can
|
||||
; be used.
|
||||
;
|
||||
; ovector array size is always (n + 1) * 3, where n is a number of
|
||||
; possible capture strings in the submitted pattern for the
|
||||
; $$compile^pcre(). The exact number of usable pairs of integers in
|
||||
; ovector array is by the $$exec^pcre().
|
||||
;
|
||||
w "ovecsize: ",$$ovecsize^pcre(.ref),!
|
||||
|
||||
; Get the captured data in an old way
|
||||
f i=0:1:count-1 d
|
||||
. s begin=$$ovector^pcre(.ref,i*2)+1
|
||||
. s end=$$ovector^pcre(.ref,i*2+1)
|
||||
. s s=$ze(subject,begin,end)
|
||||
. w i,": ",s,!
|
||||
|
||||
; See what's in the nametable
|
||||
;
|
||||
; $$nametable^pcre returns i-th element of nametable array, where the
|
||||
; index of the ovector array is passed by the reference in n, and the
|
||||
; return value is a name.
|
||||
;
|
||||
f i=1:1 s name=$$nametable^pcre(.ref,.i,.n) q:name="" d
|
||||
. s begin=$$ovector^pcre(.ref,n*2)+1 ; the returned subject index in n
|
||||
. s end=$$ovector^pcre(.ref,n*2+1)
|
||||
. s s=$ze(subject,begin,end)
|
||||
. w name,": ",s,!
|
||||
|
||||
; Use $$substring^pcre() to get the captured string instead of playing
|
||||
; with $$ovector^pcre().
|
||||
f i=0:1:count-1 w i,": ",$$substring^pcre(.ref,.i),!
|
||||
|
||||
; .. and get the begin and the end index of the captured data in the
|
||||
; subject, as a side effect.
|
||||
f i=0:1:count-1 d
|
||||
. w i,": ",$$substring^pcre(.ref,.i,.begin,.end),!
|
||||
. w "begin: ",begin,!
|
||||
. w "end: ",end,!
|
||||
|
||||
; Get some details on compiled pattern
|
||||
w "options: ",$$fullinfo^pcre(.ref,"OPTIONS"),!
|
||||
w "capture count: ",$$fullinfo^pcre(.ref,"CAPTURECOUNT"),!
|
||||
w "jit: ",$$fullinfo^pcre(.ref,"JIT"),!
|
||||
w "min length: ",$$fullinfo^pcre(.ref,"MINLENGTH"),!
|
||||
|
||||
; Free the data internally allocated for the PCRE structures
|
||||
;
|
||||
d free^pcre(.ref)
|
||||
|
||||
; Finally, raise an example exception
|
||||
;
|
||||
; see "Exception Handler Examples"
|
||||
;
|
||||
w $t(api+4^pcreexamples),!
|
||||
w $$compile^pcre("aa)bb"),!
|
||||
w "should never be written, the %PCRE-E-COMPILE should be raised",!
|
||||
q
|
||||
|
||||
apitrap
|
||||
w "apitrap^pcreexamples",!
|
||||
q
|
||||
|
||||
|
||||
|
||||
|
||||
; Perl5 Global Match Compatibility
|
||||
;
|
||||
; Global match as with /g switch on regular expressions in Perl5 is supported.
|
||||
;
|
||||
; See $$global^pcre and $$replace^pcre examples.
|
||||
|
||||
|
||||
; Compatibility Case: Empty Matches
|
||||
;
|
||||
|
||||
; Global Match
|
||||
;
|
||||
p5global
|
||||
w "$ perl -e '$_ = ""aa""; print ""1: $1\n"" while /(b*|aa)/mg'",!
|
||||
zsy "perl -e ""\$_ = \""aa\""; print \""1: \$1\n\"" while /(b*|aa)/mg"""
|
||||
d global^pcre("aa","b*|aa",.n) zwr
|
||||
q
|
||||
|
||||
; Global Replace
|
||||
;
|
||||
p5replace
|
||||
w "$ perl -e '$_ = ""aa""; s/(b*|a)/Xy/g; print ""$_\n""'",!
|
||||
zsy "perl -e ""\$_ = \""aa\""; s/(b*|a)/Xy/g; print \""\$_\n\"""""
|
||||
w $$replace^pcre("aa","(b*|a)","Xy"),!
|
||||
|
||||
w "$ perl -e '$_ = ""aa""; s/(b*|aa)/Xy/g; print ""$_\n""'",!
|
||||
zsy "perl -e ""\$_ = \""aa\""; s/(b*|aa)/Xy/g; print \""\$_\n\"""""
|
||||
w $$replace^pcre("aa","(b*|aa)","Xy"),!
|
||||
|
||||
w "$ perl -e '$_ = ""aaa""; s/(b*|aa)/Xy/g; print ""$_\n""'",!
|
||||
zsy "perl -e ""\$_ = \""aaa\""; s/(b*|aa)/Xy/g; print \""\$_\n\"""""
|
||||
w $$replace^pcre("aaa","(b*|aa)","Xy"),!
|
||||
q
|
||||
|
||||
|
||||
; Compatibility Case: New Line Characters
|
||||
;
|
||||
|
||||
; Multi-line with LF
|
||||
;
|
||||
p5lf
|
||||
w "perl -e '$_ = ""aa\nbb""; print ""1: $1\n"" while /(.*)/mg'",!
|
||||
zsy "perl -e ""\$_ = \""aa\nbb\""; print \""1: \$1\n\"" while /(.*)/mg"""
|
||||
d global^pcre("aa"_$c(10)_"bb",".*",.n,,"multiline|nl_lf") zwr
|
||||
q
|
||||
|
||||
; Various New Line Specs
|
||||
;
|
||||
p5nl
|
||||
d global^pcre("aa"_$c(13)_$c(10)_"bb",".*",.n,,"multiline|nl_lf") zwr
|
||||
d global^pcre("aa"_$c(13)_$c(10)_"bb",".*",.n,,"multiline|nl_cr") zwr
|
||||
d global^pcre("aa"_$c(13)_$c(10)_"bb",".*",.n,,"multiline|nl_crlf") zwr
|
||||
q
|
||||
|
||||
|
||||
|
||||
; PCRE library version
|
||||
;
|
||||
version
|
||||
w $$version^pcre,!
|
||||
q
|
||||
|
||||
; PCRE compile time defaults
|
||||
;
|
||||
newline
|
||||
w $$config^pcre("NEWLINE"),!
|
||||
q
|
||||
|
||||
utf8support
|
||||
w $$config^pcre("UTF8"),!
|
||||
q
|
||||
|
||||
; Stack Usage
|
||||
;
|
||||
; PCRE's stack usage discover procedure
|
||||
;
|
||||
stackusage
|
||||
w $$stackusage^pcre,!
|
||||
q
|
||||
|
||||
|
||||
|
||||
; Locale Support Examples
|
||||
;
|
||||
; Polish language has been used as an example for I18N support in PCRE.
|
||||
;
|
||||
|
||||
; The example word "dąb" (encoded here in UTF-8) is an "oak" in Polish.
|
||||
;
|
||||
; The second letter in "dąb" is <aogonek> (I18N) which is:
|
||||
; $c(177) in ISO8859-2,
|
||||
; $c(261) in UTF-8,
|
||||
; see http://en.wikipedia.org/wiki/Polish_code_pages for complete listing
|
||||
;
|
||||
|
||||
; Note of $CHAR(n) in different GT.M character modes:
|
||||
;
|
||||
; In UTF-8 mode $c(177) will return two octet encoded UTF-8 char is
|
||||
; probably not an expected result when working with single octet ISO
|
||||
; encoded chars.
|
||||
;
|
||||
; Use $zch(177) to create single octet ISO char, but be prepared for
|
||||
; %GTM-E-BADCHAR errors. Also the result of $l(), $a() and others might
|
||||
; be not what is expected.
|
||||
;
|
||||
|
||||
|
||||
; Locale: C or POSIX (i.e. no localization)
|
||||
;
|
||||
nolocale
|
||||
w $zchset,!
|
||||
w $$match^pcre("d"_$zch(177)_"b","\w{3}",.n,,,),! zwr
|
||||
q
|
||||
|
||||
; Locale: ISO
|
||||
;
|
||||
isolocale
|
||||
w $zchset,!
|
||||
w $$match^pcre("d"_$zch(177)_"b","\w{3}",.n,,,"pl_PL"),! zwr
|
||||
q
|
||||
|
||||
; Locale: UTF-8
|
||||
;
|
||||
utflocale
|
||||
; M and UTF-8 mode
|
||||
w $$match^pcre("d"_$zch(196)_$zch(133)_"b","\w{3}",.n,,"UTF8|UCP","pl_PL.UTF8"),! zwr
|
||||
|
||||
; UTF-8 mode only
|
||||
w $$match^pcre("d"_$c(261)_"b","\w{3}",.n,,"UTF8|UCP","pl_PL.UTF8"),! zwr
|
||||
q
|
||||
|
||||
; Locale: environment ($LANG, $LC_CTYPE)
|
||||
;
|
||||
; Set the GT.M environment for LANG="pl_PL" or LANG="pl_PL.UTF8" to obtain
|
||||
; different results.
|
||||
;
|
||||
envlocale
|
||||
w $ztrnlnm("LANG"),!
|
||||
w $ztrnlnm("LC_CTYPE"),!
|
||||
w $$match^pcre("d"_$c(177)_"b","\w{3}",.n,,,"env"),! zwr
|
||||
w $$match^pcre("d"_$zch(196)_$zch(133)_"b","\w{3}",.n,,"UTF8|UCP","pl_PL.UTF8"),! zwr
|
||||
q
|
||||
|
||||
|
||||
; Notes on GT.M in UTF-8
|
||||
;
|
||||
; Enabling native support for UTF-8 in GT.M requires:
|
||||
; 1) libicu
|
||||
; 2) environment:
|
||||
; gtm_chset=UTF-8
|
||||
; gtm_icu_version=4.8
|
||||
; 3) recompiled object files for UTF-8
|
||||
;
|
||||
;
|
||||
; Instructions for UTF-8 in Debian 6
|
||||
;
|
||||
; 1) Install libicu (libicu48)
|
||||
; $ apt-get install libicu48
|
||||
; 2) append environment setup to GT.M's user .bash_profile
|
||||
; export gtm_chset=UTF-8
|
||||
; export gtm_icu_version=4.8
|
||||
; 3) remove *.o files from the GT.M installation directory
|
||||
; $ rm /opt/gtm/*.o
|
||||
; 4) allow GT.M's user to write new object files
|
||||
; $ chown gtm /opt/gtm
|
||||
;
|
||||
;
|
||||
; Startup errors in UTF-8 mode
|
||||
;
|
||||
; %GTM-E-INVOBJ, Cannot ZLINK object file due to unexpected format
|
||||
; %GTM-I-TEXT, Object compiled with CHSET=M which is different from $ZCHSET
|
||||
;
|
||||
; The above errors are written by the GT.M at the startup when the environment
|
||||
; has the correct setup for the UTF-8, but GT.M can't use already existing
|
||||
; object files for execution, because they were compiled for the M charset.
|
||||
; Remove all GT.M's object files like in step 3) in the "Instructions for
|
||||
; UTF-8 in Debian 6" above.
|
||||
;
|
||||
|
||||
|
||||
|
||||
; Match Limits
|
||||
;
|
||||
; PCRE has built-in limits on internal matching and recursion.
|
||||
;
|
||||
; Those limits prevent the PCRE engine from a very long runs, especially
|
||||
; when there would be no matches and all possible paths in the match
|
||||
; tree must be checked.
|
||||
;
|
||||
; Functions using $$compile^pcre and the $$compile^pcre itself allows
|
||||
; setting MATCH_LIMIT and MATCH_LIMIT_RECURSION in optional arguments
|
||||
; named mlimit and reclimit:
|
||||
;
|
||||
; $$compile^pcre(pattern,options,locale,mlimit,reclimit)
|
||||
; $$match^pcre(subject,pattern,match,capture,options,locale,mlimit,reclimit)
|
||||
; $$global^pcre(subject,pattern,match,capture,options,locale,mlimit,reclimit)
|
||||
; $$replace^pcre(subject,pattern,subst,first,last,options,locale,mlimit,reclimit)
|
||||
;
|
||||
; If the mlimit or reclimit are not specified, the PCRE library
|
||||
; compilation time defaults are used.
|
||||
;
|
||||
limits
|
||||
w "Compile time (default) MATCH_LIMIT is: ",$$config^pcre("MATCH_LIMIT"),!
|
||||
w "Compile time (default) MATCH_LIMIT_RECURSION is: ",$$config^pcre("MATCH_LIMIT"),!
|
||||
q
|
||||
|
||||
; Example pattern with a very long run time
|
||||
;
|
||||
longrun
|
||||
w $$match^pcre("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa","(\D+|<\d+>)*[!?]",.n),! zwr
|
||||
w "should never be written, the %PCRE-E-MATCHLIMIT should be raised",!
|
||||
q
|
||||
|
||||
; Equal to the longrun^pcreexamples, but corrected pattern
|
||||
;
|
||||
shortrun
|
||||
w $$match^pcre("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa","((?>\D+)|<\d+>)*[!?]",.n),! zwr
|
||||
q
|
||||
|
||||
; Enforced mlimit
|
||||
;
|
||||
enforcedlimit
|
||||
w $$match^pcre("aaaaaa","(.)(.)",.n,,,,2),! zwr
|
||||
w "should never be written, the %PCRE-E-MATCHLIMIT should be raised",!
|
||||
q
|
||||
|
||||
|
||||
|
||||
; Exception Handling
|
||||
;
|
||||
; Error conditions are handled by setting the $zc to user codes, see labels at
|
||||
; the end of this file. When neither $zt nor $et are set by the user, the
|
||||
; default handler (trap^pcre) is used within $zt mechanism.
|
||||
;
|
||||
; The default handler will write out the details of the exception, and
|
||||
; depending on the caller type, it will re raise the exception. This will lead
|
||||
; to:
|
||||
; a) writing the exception details, when called from the GT.M prompt,
|
||||
; b) writing the exception details, the M code place when the pcre routine
|
||||
; was called, and terminating the GT.M image.
|
||||
;
|
||||
; The user should define own exception handler using $zt or $et, see
|
||||
; pcreexamples.m for example exception handlers.
|
||||
;
|
||||
|
||||
|
||||
; Exception Handler Examples
|
||||
;
|
||||
|
||||
; No handler
|
||||
;
|
||||
nohandler
|
||||
s ($ec,$et,$zt)=""
|
||||
s x=$$compile^pcre("a)b")
|
||||
w "will never be written",!
|
||||
q
|
||||
;
|
||||
; GTM>d nohandler^pcreexamples
|
||||
; %PCRE-E-COMPILE, Pattern compilation failed, unmatched parentheses in a <-- HERE
|
||||
; %PCRE-I-RTSLOC, At M source location nohandler+2^pcreexamples
|
||||
; %GTM-E-SETECODE, Non-empty value assigned to $ECODE (user-defined error trap)
|
||||
; %GTM-I-RTSLOC, At M source location trap+32^pcre
|
||||
; $ (GT.M image has been terminated)
|
||||
;
|
||||
|
||||
|
||||
; Simple handler
|
||||
;
|
||||
myexception1
|
||||
s $zt="zg "_$zl_":mytrap1^pcreexamples"
|
||||
s x=$$compile^pcre("a)b")
|
||||
w "will never be written",!
|
||||
q
|
||||
|
||||
mytrap1
|
||||
w "it's a trap",!
|
||||
w $ec,!
|
||||
s $ec=""
|
||||
q
|
||||
;
|
||||
; GTM>d myexception1^pcreexamples
|
||||
; it's a trap
|
||||
; ,U16392,
|
||||
; GTM>
|
||||
;
|
||||
|
||||
|
||||
; Simple handler with pcre exception details
|
||||
;
|
||||
myexception2
|
||||
s $zt="d trap^pcre("_$st_") zg "_$zl_":mytrap2^pcreexamples"
|
||||
s x=$$compile^pcre("a)b")
|
||||
w "will never be written",!
|
||||
q
|
||||
|
||||
mytrap2
|
||||
w "it's a trap",!
|
||||
w $ec,!
|
||||
s $ec=""
|
||||
q
|
||||
;
|
||||
; GTM>d myexception2^pcreexamples
|
||||
; %PCRE-E-COMPILE, Pattern compilation failed, unmatched parentheses in a <-- HERE
|
||||
; %PCRE-I-RTSLOC, At M source location myexception2+2^pcreexamples
|
||||
; it's a trap
|
||||
; ,U16392,
|
||||
; GTM>
|
||||
;
|
||||
; In this example the trap^pcre is called with optional argument (level
|
||||
; of M execution stack), for which trap^pcre will produce the
|
||||
; %PCRE-I-RTSLOC details.
|
||||
;
|
||||
; DETAILS:
|
||||
; The trap^pcre is executed in the stack frame where the error condition
|
||||
; occurred, that gives the trap^pcre routine an access to the local
|
||||
; variables like locale (locale name) or err (PCRE error message).
|
||||
; The following zg command drops stack frames up to the current frame
|
||||
; (the frame where the s $zt=.. is used), and executes the mytrap label,
|
||||
; where locale or err is not available.
|
||||
;
|
||||
|
||||
|
||||
; Simple handler with limited pcre exception details
|
||||
;
|
||||
myexception3
|
||||
s $zt="zg "_$zl_":mytrap3^pcreexamples"
|
||||
s x=$$compile^pcre("a)b")
|
||||
w "will never be written",!
|
||||
q
|
||||
|
||||
mytrap3
|
||||
d trap^pcre($st)
|
||||
w "it's a trap",!
|
||||
w $ec,!
|
||||
s $ec=""
|
||||
q
|
||||
;
|
||||
; GTM>d myexception3^pcreexamples
|
||||
; %PCRE-E-COMPILE, Pattern compilation failed, unknown reason
|
||||
; %PCRE-I-RTSLOC, At M source location myexception3+2^pcreexamples
|
||||
; it's a trap
|
||||
; ,U16392,
|
||||
; GTM>
|
||||
;
|
||||
; DETAILS:
|
||||
; The trap^pcre is executed in the stack frame where the compile^pcre
|
||||
; was called. The deeper stack frames has already been dropped by the
|
||||
; zg command, so the err local variable is not available in this
|
||||
; context. Thats why trap^pcre doesn't know the exact reason why the
|
||||
; %PCRE-E-COMPILE was raised.
|
||||
;
|
||||
|
||||
|
||||
; Note on $st() and repeated exceptions
|
||||
;
|
||||
; The $st() function returns information connected with $ec codes in
|
||||
; a stack manner. That means that when once the $ec was set at n-th
|
||||
; execution level, any future exceptions at that level won't change
|
||||
; the $st() output for that level unless $ec is cleared.
|
||||
;
|
||||
; Always clear $ec when the exception handling is done.
|
||||
;
|
||||
|
||||
|
||||
; Execute all of the routines in this file
|
||||
;
|
||||
routines
|
||||
w ">> test^pcreexamples",!
|
||||
d test^pcreexamples
|
||||
|
||||
w !,">> match^pcreexamples",!
|
||||
d match^pcreexamples
|
||||
|
||||
w !,">> global^pcreexamples",!
|
||||
d global^pcreexamples
|
||||
|
||||
w !,">> replace^pcreexamples",!
|
||||
d replace^pcreexamples
|
||||
|
||||
w !,">> p5global^pcreexamples",!
|
||||
d p5global^pcreexamples
|
||||
|
||||
w !,">> p5replace^pcreexamples",!
|
||||
d p5replace^pcreexamples
|
||||
|
||||
w !,">> p5lf^pcreexamples",!
|
||||
d p5lf^pcreexamples
|
||||
|
||||
w !,">> p5nl^pcreexamples",!
|
||||
d p5nl^pcreexamples
|
||||
|
||||
w !,">> version^pcreexamples",!
|
||||
d version^pcreexamples
|
||||
|
||||
w !,">> newline^pcreexamples",!
|
||||
d newline^pcreexamples
|
||||
|
||||
w !,">> utf8support^pcreexamples",!
|
||||
d utf8support^pcreexamples
|
||||
|
||||
w !,">> stackusage^pcreexamples",!
|
||||
d stackusage^pcreexamples
|
||||
|
||||
w !,">> nolocale^pcreexamples",!
|
||||
d nolocale^pcreexamples
|
||||
|
||||
w !,">> isolocale^pcreexamples",!
|
||||
d isolocale^pcreexamples
|
||||
|
||||
w !,">> utflocale^pcreexamples",!
|
||||
d utflocale^pcreexamples
|
||||
|
||||
w !,">> envlocale^pcreexamples",!
|
||||
d envlocale^pcreexamples
|
||||
|
||||
w !,">> limits^pcreexamples",!
|
||||
d limits^pcreexamples
|
||||
|
||||
w !,">> longrun^pcreexamples",!
|
||||
w "(skipped, uncomment to raise the exception)",!
|
||||
; d longrun^pcreexamples
|
||||
|
||||
w !,">> shortrun^pcreexamples",!
|
||||
d shortrun^pcreexamples
|
||||
|
||||
w !,">> enforcedlimit^pcreexamples",!
|
||||
w "(skipped, uncomment to raise the exception)",!
|
||||
; d enforcedlimit^pcreexamples
|
||||
|
||||
w !,">> nohandler^pcreexamples",!
|
||||
w "(skipped, uncomment to raise the exception)",!
|
||||
; d nohandler^pcreexamples
|
||||
|
||||
w !,">> myexception1^pcreexamples",!
|
||||
d myexception1^pcreexamples
|
||||
|
||||
w !,">> myexception2^pcreexamples",!
|
||||
d myexception2^pcreexamples
|
||||
|
||||
w !,">> myexception3^pcreexamples",!
|
||||
d myexception3^pcreexamples
|
||||
q
|
||||
46
samples/M/postconditional.m
Normal file
46
samples/M/postconditional.m
Normal file
@@ -0,0 +1,46 @@
|
||||
;
|
||||
; M code examples contrasting postconditionals with IF-commands
|
||||
;
|
||||
post1 ; postconditional in set command
|
||||
set a=5
|
||||
set b=10
|
||||
set c=25
|
||||
I 0 ;purposely set $TEST to false
|
||||
write "$TEST special variable (before post-condition)=",$TEST
|
||||
set:(a<b) c=b
|
||||
write "$TEST special variable (after post-condition) =",$TEST
|
||||
write "c =",c,!
|
||||
quit
|
||||
;
|
||||
post2 ; postconditional in write command
|
||||
set a=5
|
||||
set b=10
|
||||
I 0 ;purposely set $TEST to false
|
||||
write "$TEST special variable (before post-condition)=",$TEST
|
||||
write:(a<b) "variable a=",a," is smaller than b=",b,!
|
||||
write "$TEST special variable (after post-condition) =",$TEST
|
||||
write:(a>b) "variable a=",a," is larger than b=",b,!
|
||||
write "$TEST special variable (after post-condition) =",$TEST
|
||||
quit
|
||||
;
|
||||
if1 ; if command
|
||||
set a=5
|
||||
set b=10
|
||||
set c=25
|
||||
I 0 ;purposely set $TEST to false
|
||||
write "$TEST special variable (before IF)=",$TEST
|
||||
if (a<b) set c=b
|
||||
write "$TEST special variable (after IF) =",$TEST
|
||||
write c,!
|
||||
quit
|
||||
;
|
||||
if2 ; postconditional in write command
|
||||
set a=5
|
||||
set b=10
|
||||
I 0 ;purposely set $TEST to false
|
||||
write "$TEST special variable (before IF)=",$TEST
|
||||
if (a<b) write "variable a=",a," is smaller than b=",b,!
|
||||
write "$TEST special variable (after IF) =",$TEST
|
||||
if (a>b) write "variable a=",a," is larger than b=",b,!
|
||||
write "$TEST special variable (after IF) =",$TEST
|
||||
quit
|
||||
6
samples/M/primes.m
Normal file
6
samples/M/primes.m
Normal file
@@ -0,0 +1,6 @@
|
||||
; part of Keith Lynch's .signature; it prints a table of primes,
|
||||
; including code to format it neatly into columns -- DPBS
|
||||
; -- M Technology and MUMPS Language FAQ, Part 1/2
|
||||
;
|
||||
|
||||
f p=2,3:2 s q=1 x "f f=3:2 q:f*f>p!'q s q=p#f" w:q p,?$x\8+1*8
|
||||
49
samples/M/url.m
Normal file
49
samples/M/url.m
Normal file
@@ -0,0 +1,49 @@
|
||||
;
|
||||
; This file is part of DataBallet.
|
||||
; Copyright (C) 2012 Laurent Parenteau <laurent.parenteau@gmail.com>
|
||||
;
|
||||
; DataBallet is free software: you can redistribute it and/or modify
|
||||
; it under the terms of the GNU Affero General Public License as published by
|
||||
; the Free Software Foundation, either version 3 of the License, or
|
||||
; (at your option) any later version.
|
||||
;
|
||||
; DataBallet is distributed in the hope that it will be useful,
|
||||
; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
; GNU Affero General Public License for more details.
|
||||
;
|
||||
; You should have received a copy of the GNU Affero General Public License
|
||||
; along with DataBallet. If not, see <http://www.gnu.org/licenses/>.
|
||||
;
|
||||
|
||||
decode(val)
|
||||
;
|
||||
; Decoded a URL Encoded string
|
||||
;
|
||||
new decoded,c,i
|
||||
|
||||
set decoded=""
|
||||
for i=1:1:$zlength(val) do
|
||||
. set c=$zextract(val,i,i)
|
||||
. if c="+" set decoded=decoded_" "
|
||||
. else if c'="%" set decoded=decoded_c
|
||||
. else set decoded=decoded_$zchar($$FUNC^%HD($zextract(val,i+1,i+2))) set i=i+2
|
||||
quit decoded
|
||||
|
||||
encode(val)
|
||||
;
|
||||
; Encoded a string for URL usage
|
||||
;
|
||||
new encoded,c,i
|
||||
set encoded=""
|
||||
|
||||
; Populate safe char only the first time
|
||||
if '$data(safechar) for i=45,46,95,126,48:1:57,65:1:90,97:1:122 set safechar($zchar(i))=""
|
||||
|
||||
for i=1:1:$zlength(val) do
|
||||
. set c=$zextract(val,i,i)
|
||||
. if $data(safechar(c)) set encoded=encoded_c
|
||||
. else if c=" " set encoded=encoded_"+"
|
||||
. else set encoded=encoded_"%"_$$FUNC^%DH($zascii(c),2)
|
||||
|
||||
quit encoded
|
||||
1949
samples/M/zmwire.m
Normal file
1949
samples/M/zmwire.m
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user