PACKET idadruckDEFINES listendruck,ausdruckauswerten,bschirm,drucker, namederdruckausgabe,namederdruckausgabeohne,druckausgabeausgeben,ruecksprung, zurueck,postext,seitenweise:LET linkeklammer="<",rechteklammer=">", platzhalter="�",linefeed=" ",trenner=" ",kzkosmetik="#",kzseitenzahl="%", ddrucker=1,dbschirm=2,mlddrucken=58,mldaufb=190;TEXT VAR filename:= "ISP-Liste";INT CONST drucker:=ddrucker,bschirm:=dbschirm;FILE VAR ausgfile; INT VAR dbauswertung,anzzeilen,zeilenzaehler:=0,fusszeilen:=0,kopfzeilen:=0, aktuelleseite:=0,aktuellerds:=0,zeilenlaenge,verbund;BOOL VAR tupelbearbeitet ,isppageform:=FALSE ;TEXT VAR restderletztenzeile:="";TEXT VAR schriftart:="" ,kopfbereich:="",fussbereich:="",kosmetikbereich:="zzzz";REAL VAR links,oben; #nurtest!!!!!!PROC standardmeldung(INT CONST mldaufb,TEXT CONST t):fehler( "MELDUNG: "+text(mldaufb)+" "+t)ENDPROC standardmeldung;PROC editiere(TEXT CONST fname,BOOL CONST f):edit(fname)ENDPROC editiere;PROC enter(INT CONST i) :ENDPROC enter;#PROC seitenweise(BOOL CONST jn):isppageform:=jnENDPROC seitenweise;BOOL PROC seitenweise:isppageformENDPROC seitenweise;TEXT PROC rechtscompress(TEXT CONST zeile):TEXT VAR z:=zeile;INT VAR p:=length(zeile); WHILE p>0CAND (zSUB p)=trennerREP pDECR 1PER ;z:=text(z,p);zENDPROC rechtscompress;INT PROC bestimmevorhandeneblanks(TEXT CONST zeile):INT VAR vorhandeneblanks:=0,i;FOR iFROM 1UPTO length(zeile)REP IF (zeileSUB i)= trennerTHEN vorhandeneblanksINCR 1FI UNTIL (zeileSUB i)<>trennerPER ; vorhandeneblanksENDPROC bestimmevorhandeneblanks;TEXT PROC textmitfuehrendenblanks(TEXT CONST z,INT CONST anzblanks):INT VAR vorhandeneblanks:=0;TEXT VAR zeile:=z;vorhandeneblanks:= bestimmevorhandeneblanks(zeile);IF vorhandeneblanks>anzblanksTHEN zeilekuerzenELSE mitblanksauffuellenFI ;zeile.zeilekuerzen:zeile:=subtext( zeile,vorhandeneblanks-anzblanks).mitblanksauffuellen:zeile:=(anzblanks- vorhandeneblanks)*trenner+zeile.ENDPROC textmitfuehrendenblanks;TEXT PROC aktfilename:IF aktuellerds=0THEN filenameELSE filename+"."+text(aktuellerds) FI ENDPROC aktfilename;PROC schreibebereich(TEXT CONST bereich,BOOL CONST kopf):INT VAR von:=0,bis;TEXT VAR zeile:="";bis:=pos(bereich,linefeed);WHILE bis>0REP zeile:=subtext(bereich,von+1,bis-1);IF kopfTHEN changeall(zeile, kzseitenzahl,text(aktuelleseite));zeilenzaehlerINCR 1FI ;putline(ausgfile, zeile);von:=bis;bis:=pos(bereich,linefeed,von+1);PER ENDPROC schreibebereich; PROC schreibekopf:schreibebereich(kopfbereich,TRUE )ENDPROC schreibekopf; PROC schreibefuss:schreibebereich(fussbereich,FALSE )ENDPROC schreibefuss; PROC seitenvorschub:schreibefuss;IF filefastvollTHEN ausgabedateianlegenELSE putline(ausgfile,"#page#")FI ;zeilenzaehler:=0;aktuelleseiteINCR 1; schreibekopf.filefastvoll:lines(ausgfile)>=3000COR storage(old(aktfilename))> 700.ENDPROC seitenvorschub;PROC pageeinfuegen:putline(ausgfile,"#page#"); zeilenzaehler:=0;ENDPROC pageeinfuegen;PROC zeilenvorschubundfussdrucken: WHILE zeilenzaehler0THEN auszeile:=restderletztenzeile;IF keintrennerzwischenzeilenTHEN auszeileCAT trennerFI FI ;auszeileCAT zeile; restderletztenzeile:="";IF length(auszeile)<=zeilenlaengeTHEN putlein( auszeile,FALSE )ELSE bestimmelinkenrand;WHILE length(auszeile)>zeilenlaenge REP trennpositionbestimmen;zeileausgebenundkürzen;PER ;IF length(auszeile)>0 THEN IF blocksatzTHEN putlein(auszeile,FALSE )ELSE restderletztenzeile:= textmitfuehrendenblanks(auszeile,linkerrand)FI FI FI . keintrennerzwischenzeilen:(restderletztenzeileSUB length(restderletztenzeile) )<>trennerCAND (zeileSUB 1)<>trenner.bestimmelinkenrand:linkerrand:= bestimmevorhandeneblanks(auszeile);.trennpositionbestimmen:trennpos:= zeilenlaenge;WHILE trennpos>linkerrandCAND (auszeileSUB trennpos)<>trenner REP trennposDECR 1PER ;IF trennpos<=linkerrandTHEN trennpos:=max(zeilenlaenge ,linkerrand+1);WHILE trennpos<=length(auszeile)CAND (auszeileSUB trennpos)<> trennerREP trennposINCR 1PER ;FI .zeileausgebenundkürzen:putlein( rechtscompress(text(auszeile,trennpos-1)),FALSE );auszeile:=compress(subtext( auszeile,trennpos+1));IF length(auszeile)>0THEN auszeile:= textmitfuehrendenblanks(auszeile,linkerrand)FI .ENDPROC putzeile;PROC nextergebnistupel:INT VAR dnr;qsucc(verbund,dnr);tupelbearbeitet:=FALSE ; verbund:=gettiefennr(verbund);IF dbstatus=endoffileCAND dbauswertung= ordernewstackTHEN auswertungfortsetzen;dbauswertung:=dbstatus;qsucc(verbund, dnr);verbund:=gettiefennr(verbund);FI ENDPROC nextergebnistupel;TEXT PROC sonderfunktion(TEXT CONST stcode):TEXT VAR t:=stcode,ausdruck:=stcode;IF ( ausdruckSUB 1)=linkeklammerTHEN deletechar(ausdruck,1)FI ;IF (ausdruckSUB length(ausdruck))=rechteklammerTHEN deletechar(ausdruck,length(ausdruck))FI ; IF ausdruck="tagesdatum"THEN t:=dateELIF ausdruck="tag"THEN t:=day(date(date) )ELIF ausdruck="monat"THEN t:=month(date(date))ELIF ausdruck="jahr"THEN t:= year(date(date))ELIF ausdruck="zeit"THEN t:=timeofdayELIF ausdruck="tt"THEN t :=text(date,2)ELIF ausdruck="mm"THEN t:=subtext(date,4,5)ELIF ausdruck="jj" THEN t:=subtext(date,7)FI ;tENDPROC sonderfunktion;TEXT PROC aufbereitetezeile(TEXT CONST zeile,einfuegstellen):TEXT VAR auszeile:="", auswert:="",ausdruck:="";INT VAR p:=1,pp,ppalt:=1,ix,laenge;BOOL VAR rbuendig ,druckvar;pp:=pos(zeile,platzhalter,ppalt);WHILE pp>0REP auszeileCAT subtext( zeile,ppalt,pp-1);ix:=decodezahl(einfuegstellen,p);IF ix>0THEN getsteuercode( ix,ausdruck,laenge,rbuendig,druckvar);IF druckvarTHEN auswert:= ausdruckauswerten(ausdruck);aufbereitenundschreiben;ELSE auswert:= sonderfunktion(ausdruck);aufbereitenundschreiben;FI FI ;ppalt:=pp+1;pp:=pos( zeile,platzhalter,ppalt);PER ;auszeileCAT subtext(zeile,ppalt);auszeile. aufbereitenundschreiben:IF laenge>0THEN IF length(auswert)>=laengeCOR NOT rbuendigTHEN auswert:=text(auswert,laenge)ELSE auswert:=((laenge-length( auswert))*" ")+auswertFI ;FI ;auszeileCAT auswert.ENDPROC aufbereitetezeile; PROC druckezeile(TEXT CONST zeile,einfuegstellen):putzeile(aufbereitetezeile( zeile,einfuegstellen))ENDPROC druckezeile;PROC druckeblock(INT CONST blocknr) :INT VAR aktzeile:=1,pb,pz,nextblock,nextblockvorzeile;REP IF aktzeile=1CAND verbund=blocknrTHEN tupelbearbeitet:=TRUE FI ;pb:=1;pz:=1;bestimmeunterblock; WHILE aktzeile<=getzeilenanzahl(blocknr)COR aktzeile=nextblockvorzeileREP IF aktzeile=nextblockvorzeileTHEN IF verbundblocknrTHEN LEAVE druckeblockFI ELIF verbund<>blocknrTHEN LEAVE druckeblockFI UNTIL blocknr=0PER .innerhalbkosmetikbereich:(blocknr=0)CAND (( aktzeile>=code(kosmetikbereichSUB 1)CAND aktzeile<=code(kosmetikbereichSUB 2) )COR (aktzeile>=code(kosmetikbereichSUB 3)CAND aktzeile<=code(kosmetikbereich SUB 4))).bestimmeunterblock:nextblock:=decodezahl(getunterbloecke(blocknr),pb );nextblockvorzeile:=decodezahl(getvorzeilennr(blocknr),pz);.ENDPROC druckeblock;PROC listendruck(INT CONST nr):listendruck(nr,bschirm)ENDPROC listendruck;PROC ausgabedateianlegen:aktuellerdsINCR 1;forget(aktfilename, quiet);ausgfile:=sequentialfile(output,aktfilename);putlein(schrifttyp,TRUE ) ;putlein(startanweisung,TRUE );zeilenzaehler:=0.schrifttyp:IF schriftart="" THEN ""ELSE "#type ("""+schriftart+""")#"FI .startanweisung:"#start("+text( links)+","+text(oben)+")# ".ENDPROC ausgabedateianlegen;PROC headundbottommerken:#block(0)nachheadundbottomuntersuchen#INT VAR aktzeile:=1 ,p;TEXT VAR ausdruck:="",zeile:="";kopfzeilen:=0;fusszeilen:=0;kopfbereich:= "";fussbereich:="";kosmetikbereich:="zzzz";WHILE aktzeile<=getzeilenanzahl(0) REP zeile:=getzeile(0,aktzeile);aktzeileINCR 1;p:=pos(zeile,kzkosmetik);IF p> 0THEN ausdruckeinlesen;IF ausdruck="head"THEN kopfeinlesenELIF ausdruck= "bottom"THEN fusseinlesenFI ;FI ;PER .ausdruckeinlesen:ausdruck:=compress( subtext(zeile,p+1,pos(zeile,kzkosmetik,p+1)-1)).bereichsende:p:=pos(zeile, kzkosmetik);IF p>0THEN ausdruckeinlesen;pos(";head;bottom;end;",";"+ausdruck+ ";")>0ELSE FALSE FI .kopfeinlesen:replace(kosmetikbereich,1,code(aktzeile-1)) ;REP zeile:=getzeile(0,aktzeile);aktzeileINCR 1;IF bereichsendeTHEN replace( kosmetikbereich,2,code(aktzeile-1));LEAVE kopfeinlesenELSE kopfzeilenINCR 1; zeile:=aufbereitetezeile(zeile,geteinfuegstellen(0,aktzeile-1));kopfbereich CAT (zeile+linefeed)FI PER .fusseinlesen:replace(kosmetikbereich,3,code( aktzeile-1));REP zeile:=getzeile(0,aktzeile);aktzeileINCR 1;IF bereichsende THEN replace(kosmetikbereich,4,code(aktzeile-1));LEAVE fusseinlesenELSE fusszeilenINCR 1;zeile:=aufbereitetezeile(zeile,geteinfuegstellen(0,aktzeile- 1));fussbereichCAT (zeile+linefeed)FI PER .ENDPROC headundbottommerken;PROC listendruck(INT CONST nr,INT CONST medium):REAL VAR limit;INT VAR fontnr:=0; getdruckaufbereitung(schriftart,links,oben,anzzeilen,limit);schriftartpruefen ;zeilenlaenge:=int(limit);#IF seitenweiseTHEN #headundbottommerken; aktuelleseite:=1;aktuellerds:=-1;ausgabedateianlegen;IF seitenweiseTHEN schreibekopfFI ;auswertung("QUERY."+text(nr));dbauswertung:=dbstatus; restderletztenzeile:="";verbund:=-1;tupelbearbeitet:=TRUE ;druckeblock(0);IF length(restderletztenzeile)>0THEN putzeile("")FI ;IF seitenweiseCAND fusszeilen>0THEN zeilenvorschubundfussdruckenFI ;druckegesamtliste. schriftartpruefen:disablestop;fontnr:=font(schriftart);IF iserrorTHEN schriftart:="";clearerror;ELIF fontnr=0THEN schriftart:=font(1)FI ;enablestop .druckegesamtliste:BOOL VAR cd:=commanddialogue;INT VAR i;IF seitenweiseCOR schriftart=""THEN druckausgabeausgeben(filename,medium);IF seitenweiseCAND aktuellerds>0CAND medium=druckerTHEN FOR iFROM 1UPTO aktuellerdsREP druckausgabeausgeben(filename,medium);PER FI ELSE sysout("dummy"); commanddialogue(FALSE );standardmeldung(mldaufb,"");autopageform(filename); forget(filename,quiet);sysout("");forget("dummy",quiet);commanddialogue(cd); druckausgabeausgeben(filename+".p",medium)FI .ENDPROC listendruck;TEXT PROC namederdruckausgabeohne:filenameENDPROC namederdruckausgabeohne;TEXT PROC namederdruckausgabe:filename+".p"ENDPROC namederdruckausgabe;PROC namederdruckausgabe(TEXT CONST fname):filename:=fnameENDPROC namederdruckausgabe;PROC druckausgabeausgeben(TEXT CONST fname,INT CONST medium):SELECT mediumOF CASE dbschirm:caufanfang;editiere(fname,FALSE );CASE ddrucker:standardmeldung(mlddrucken,"");print(fname);enter(1)OTHERWISE : errorstop("Falscher Druck-Code")ENDSELECT ;zurueck.caufanfang:FILE VAR f:= sequentialfile(modify,fname);toline(f,1).ENDPROC druckausgabeausgeben;BOOL VAR rueck:=FALSE ;PROC zurueck:rueck:=TRUE ENDPROC zurueck;BOOL PROC ruecksprung:BOOL VAR b:=rueck;rueck:=FALSE ;bENDPROC ruecksprung;LET parametergrenze="%",parametertrennzeichen="#",otherwise="*",niltext="", textbegrenzer="""";INT PROC postextende(TEXT CONST ausgabe,INT CONST aktuelleposition):INT VAR neupos:=aktuelleposition+1;WHILE (ausgabeSUB neupos )<>textbegrenzerREP neuposINCR 1;IF (ausgabeSUB neupos)=textbegrenzerCAND ( ausgabeSUB neupos+1)=textbegrenzerTHEN neuposINCR 2;FI ;UNTIL neupos>length( ausgabe)PER ;neupos+1ENDPROC postextende;INT PROC postext(TEXT CONST source, pattern,INT CONST from):INT VAR p:=from;WHILE (sourceSUB p)<>patternREP nextcharUNTIL p>length(source)PER ;#9.12.87#IF p>length(source)THEN 0ELSE p FI .nextchar:IF (sourceSUB p)=textbegrenzerTHEN p:=postextende(source,p)ELSE pINCR 1;#9.12.87#FI .ENDPROC postext;TEXT PROC dbwert(TEXT CONST feldname, BOOL VAR textvergleich):LET null="0",nulldatum="01.01.00";TEXT VAR ausgabe:= "";INT CONST fnr:=feldnr(compress(feldname));IF fnr>0THEN ausgabe:=wert(fnr); IF ((feldtyp(fnr)=intfeld)CAND (ausgabe=null))COR ((feldtyp(fnr)=datumfeld) CAND (ausgabe=nulldatum))THEN ausgabe:=""FI ;textvergleich:=NOT (feldtyp(fnr) =realfeldCOR feldtyp(fnr)=intfeld)ELSE textvergleich:=TRUE FI ;ausgabeEND PROC dbwert;TEXT PROC auswerten(TEXT CONST eingabe):INT VAR positionlinkeklammer:=1,positionrechteklammer:=1,positionlinkeskreuz, positionrechteskreuz,positionmittlereskreuz,positionparametergrenze, aktuelleposition:=1,positionotherwise,anzahldergeoeffnetenklammern;BOOL VAR ausdruckvorhanden,caseaufruf,linkeseitevariabel,rechteseitevariabel, textvergleich;TEXT VAR puffer,vergleichswert,aktuellessymbol,parameter1, ausgabe:=compress(eingabe);REP zeichenketteueberlesen; auffindeneinesspitzgeklammertenausdrucks;IF ausdruckvorhandenTHEN bestimmungdesfeldnamensfuerdieprozedurdbwert;aufrufderprozedurdbwert;IF caseaufrufTHEN bestimmungderrichtigenalternativeFI ; einsetzendesfeldwertsoderderalternative;FI ;UNTIL NOT ausdruckvorhandenPER ; ausgabe.zeichenketteueberlesen:INT VAR p:=aktuelleposition;#1#BOOL VAR innerhalbzeichenkette:=TRUE ;IF (ausgabeSUB p)=linkeklammerTHEN pINCR 1;FI ; IF aktuelleszeichenisttextbegrenzerTHEN WHILE innerhalbzeichenketteREP REP UNTIL textendeCOR aktuelleszeichenisttextbegrenzerPER ;IF NOT textendeCAND ( ausgabeSUB p)=textbegrenzerTHEN innerhalbzeichenkette:=TRUE ;pINCR 1ELSE innerhalbzeichenkette:=FALSE ;FI PER ;pDECR 1;aktuelleposition:=p; leerzeichenentfernen;FI .aktuelleszeichenisttextbegrenzer:IF (ausgabeSUB p)= textbegrenzerTHEN deletechar(ausgabe,p);TRUE ELSE pINCR 1;FALSE FI .textende: p>length(ausgabe).leerzeichenentfernen:WHILE (ausgabeSUB p)=" "REP deletechar (ausgabe,p)PER .auffindeneinesspitzgeklammertenausdrucks:#aktuelleposition:=0 ;#linkeseitevariabel:=FALSE ;rechteseitevariabel:=FALSE ;aktuelleposition:= pos(ausgabe,linkeklammer,aktuelleposition);ausdruckvorhanden:= aktuelleposition<>0;positionlinkeklammer:=aktuelleposition. bestimmungdesfeldnamensfuerdieprozedurdbwert: ueberpruefeoblinkeseitedoppeltgeklammert;bestimmedenfeldnamen;IF aktuellessymbol=rechteklammerTHEN caseaufruf:=FALSE ;fuehreleseoperationaus; ueberpruefeobrechteseitedoppeltgeklammertELSE caseaufruf:=TRUE ; positionparametergrenze:=aktuellepositionFI .fuehreleseoperationaus: aktuellepositionINCR 1;IF aktuelleposition>length(ausgabe)THEN aktuellessymbol:=rechteklammerELSE aktuellessymbol:=ausgabeSUB aktuelleposition;FI ;IF aktuellessymbol=linkeklammerTHEN anzahldergeoeffnetenklammernINCR 1ELIF aktuellessymbol=rechteklammerTHEN anzahldergeoeffnetenklammernDECR 1FI .fuehreleseoperationausmittextueberlesen :aktuellepositionINCR 1;IF (ausgabeSUB aktuelleposition)=textbegrenzerTHEN aktuelleposition:=postextende(ausgabe,aktuelleposition)FI ;IF aktuelleposition>length(ausgabe)THEN aktuellessymbol:=rechteklammerELSE aktuellessymbol:=ausgabeSUB aktuelleposition;FI ;IF aktuellessymbol= linkeklammerTHEN anzahldergeoeffnetenklammernINCR 1ELIF aktuellessymbol= rechteklammerTHEN anzahldergeoeffnetenklammernDECR 1FI . ueberpruefeoblinkeseitedoppeltgeklammert:fuehreleseoperationaus; linkeseitevariabel:=aktuellessymbol=linkeklammer.bestimmedenfeldnamen:WHILE NOT (aktuellessymbol=parametertrennzeichenOR aktuellessymbol=parametergrenze OR aktuellessymbol=rechteklammer)REP fuehreleseoperationausPER ;IF linkeseitevariabelTHEN parameter1:=(subtext(ausgabe,positionlinkeklammer+2, aktuelleposition-1))ELSE parameter1:=(subtext(ausgabe,positionlinkeklammer+1, aktuelleposition-1))FI .ueberpruefeobrechteseitedoppeltgeklammert:IF aktuellessymbol=rechteklammerTHEN rechteseitevariabel:=TRUE ; positionrechteklammer:=aktuellepositionELSE positionrechteklammer:= aktuelleposition-1FI .aufrufderprozedurdbwert:puffer:=dbwert(parameter1, textvergleich).bestimmungderrichtigenalternative: bestimmungdeserstenvergleichswertes;WHILE vergleichswertstimmtnichtuebereinundeinweiterervorhandenREP suchenaechstenvergleichswertPER ;positionrechteklammerbeicaseaufrufbestimmen; IF vergleichswertstimmtmitdemergebnisausdemdbwertaufrufuebereinTHEN bereitstellenderentsprechendenalternativeELIF (ausgabeSUB positionotherwise)= otherwiseTHEN puffer:=auswerten(subtext(ausgabe,positionotherwise+1, positionrechteklammer-1))ELSE bereitstelleneinerleerenalternativeFI . bestimmungdeserstenvergleichswertes:positionlinkeskreuz:= positionparametergrenze;positionmittlereskreuz:=postext(ausgabe, parametertrennzeichen,positionlinkeskreuz+1);vergleichswert:=subtext(ausgabe, positionlinkeskreuz+1,positionmittlereskreuz-1);rechteskreuzbestimmen. suchenaechstenvergleichswert:positionlinkeskreuz:=positionrechteskreuz; positionmittlereskreuz:=postext(ausgabe,parametertrennzeichen, positionlinkeskreuz+1);vergleichswert:=subtext(ausgabe,positionlinkeskreuz+1, positionmittlereskreuz-1);rechteskreuzbestimmen.rechteskreuzbestimmen: aktuelleposition:=positionmittlereskreuz;anzahldergeoeffnetenklammern:=0;REP fuehreleseoperationausmittextueberlesenUNTIL (anzahldergeoeffnetenklammern=0 AND (aktuellessymbol=parametertrennzeichenOR aktuellessymbol=otherwise))OR anzahldergeoeffnetenklammern<0PER ;positionrechteskreuz:=aktuelleposition; positionotherwise:=aktuelleposition. vergleichswertstimmtmitdemergebnisausdemdbwertaufrufueberein:IF textvergleich THEN vergleichswert=pufferELSE real(vergleichswert)=real(puffer)FI . bereitstellenderentsprechendenalternative:puffer:=auswerten(subtext(ausgabe, positionmittlereskreuz+1,positionrechteskreuz-1)). bereitstelleneinerleerenalternative:puffer:=niltext. vergleichswertstimmtnichtuebereinundeinweiterervorhanden:NOT vergleichswertstimmtmitdemergebnisausdemdbwertaufrufuebereinAND einweiterervergleichswertistvorhanden.einweiterervergleichswertistvorhanden: aktuellessymbol=parametertrennzeichen. positionrechteklammerbeicaseaufrufbestimmen:anzahldergeoeffnetenklammern:=0; IF aktuellessymbol<>rechteklammerTHEN WHILE NOT (anzahldergeoeffnetenklammern <0AND aktuellessymbol=rechteklammer)REP fuehreleseoperationausmittextueberlesenPER FI ;positionrechteklammer:= aktuelleposition.einsetzendesfeldwertsoderderalternative:change(ausgabe, positionlinkeklammer,positionrechteklammer,puffer).ENDPROC auswerten;TEXT PROC ausdruckauswerten(TEXT CONST ausdruck):TEXT VAR eingabe:=ausdruck;IF ( eingabeSUB 1)<>linkeklammerTHEN insertchar(eingabe,linkeklammer,1)FI ;IF ( eingabeSUB (length(eingabe)))<>rechteklammerTHEN eingabeCAT rechteklammerFI ; auswerten(eingabe)ENDPROC ausdruckauswerten;ENDPACKET idadruck;