LFormat
From Pickwiki
* A utility to print source code to an HP laser printer with various
* output options. Written by Adrian Matthews in 1994
$OPTIONS SMA.HEADING
PROMPT ''
DEFAULT.PRINTER = '\\PRINTSERV\[[Development_HP8150]]'
DEFAULT.PRINT = DQUOTE(DEFAULT.PRINTER)
ESC = CHAR(27)
READLIST PASSED.RECORDS ELSE PASSED.RECORDS = ''
COND = ESC:"(10U":ESC:'(s0P':ESC:'&k2S'
SENTENCE = CONVERT(' ',@FM,FIELD(@SENTENCE,'-',1))
OPTIONS = FIELD(@SENTENCE,'-',2,999)
CONVERT ' ' TO '' IN OPTIONS
CONVERT '-' TO @FM IN OPTIONS
NO.NUM.OPTIONS = CONVERT('0123456789','',OPTIONS)
OPT.STRING = ''
LOCATE 'S' IN NO.NUM.OPTIONS<1> SETTING POS THEN
START.LINE = TRIM(CONVERT('S','',OPTIONS<POS>))
IF NOT(NUM(START.LINE)) THEN
ERR= '-S must be followed by a number'
GOSUB ERR.HANDLER
STOP
END
OPT.STRING = 'From line - ' : START.LINE
END ELSE
START.LINE = 1
END
LOCATE 'E' IN NO.NUM.OPTIONS<1> SETTING POS THEN
END.LINE = TRIM(CONVERT('E','',OPTIONS<POS>))
IF NOT(NUM(END.LINE)) THEN
ERR = '-E must be followed by a number'
GOSUB ERR.HANDLER
STOP
END
OPT.STRING := ' to line ':END.LINE
END ELSE
END.LINE = 999999
END
LOCATE 'EXPAND' IN OPTIONS<1> SETTING POS THEN
OPT.STRING<-1> = "INCLUDEs will not be expanded"
MODE = ''
END ELSE
MODE = 'EXPAND'
OPT.STRING<-1> = "INCLUDEs will be expanded"
END
LOCATE 'P' IN OPTIONS<1> SETTING POS THEN
LANDSCAPE = @FALSE
OPT.STRING<-1> = 'Output in portrait format'
END ELSE
LANDSCAPE = @TRUE
OPT.STRING<-1> = "Output in landscape format"
END
LOCATE 'LPI' IN NO.NUM.OPTIONS<1> SETTING POS THEN
LPI = TRIM(CONVERT('LPI','',OPTIONS<POS>))
END ELSE
LPI = 8
END
BEGIN CASE
CASE LPI = 8
LPI = ESC:'&l8D'
LINES.PER.COL = 54
PORT.LINES = 80
OPT.STRING := ' at eight lines per inch'
CASE LPI = 12
LPI = ESC:'&l10D'
LINES.PER.COL=86
PORT.LINES = 126
OPT.STRING := ' at twelve lines per inch'
CASE 1
ERR = 'Lines per inch must be 8 or 12'
GOSUB ERR.HANDLER
STOP
END CASE
LOCATE 'NOLINES' IN OPTIONS<1> SETTING POS THEN
NOLINES = @TRUE
OPT.STRING<-1> = 'Line-up bars will not be printed'
END ELSE
OPT.STRING<-1> = 'Line-up bars will be printed'
NOLINES = @FALSE
END
FILE.NAME = SENTENCE<2>
RECORD.ID = SENTENCE<3>
IF FILE.NAME = '' AND RECORD.ID = '' AND OPTIONS = '' THEN
CRT @SYS.BELL
STOP
END
LINES.PER.PAGE = LINES.PER.COL * 2
IF MODE = 'EXPAND' THEN ANS= 'Y' ELSE ANS = 'S'
PASSED.RECORDS<-1> = RECORD.ID
PERFORM 'SETPTR 0,80,63,0,0,1,AT ':DEFAULT.PRINTER
IF LANDSCAPE THEN
OPEN '&HOLD&' TO F.HOLD ELSE STOP 'Cannot open the &HOLD& file'
END
ERR.FLAG = 0
TERM.WIDTH = 0
DIM REC(99) ; MAT REC = ''
DIM SAVE.INDENT(99) ; MAT SAVE.INDENT = ''
DIM AMT(99) ; MAT AMT = ''
DIM SAVE.CNT(99) ; MAT SAVE.CNT = ''
DIM SAVE.MORE(99) ; MAT SAVE.MORE = ''
VINCLUDE = 0
CALL !GETPU(2,0,TERM.WIDTH,ERR.FLAG)
IF NOLINES THEN
MASK = SPACE(200)
END ELSE
MASK = " ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179):" ":CHAR(179)
END
LOOP
REMOVE RECORD.ID FROM PASSED.RECORDS SETTING MORE.IDS
FIELD.NO = 1
LOOP
BEGIN CASE
CASE FIELD.NO = 1
LOOP
ERR = ''
IF NOT(FILE.NAME) THEN
CRT
CRT 'Enter file name : ': ; INPUT FILE.NAME
END
IF FILE.NAME THEN
OPEN FILE.NAME TO F.FILE ELSE
ERR = FILE.NAME:' is not a valid file name'
GOSUB ERR.HANDLER
FILE.NAME = ''
END
END ELSE
FIELD.NO = 99
EXIT
END
FIELD.NO += (NOT(ERR))
UNTIL NOT(ERR) REPEAT
CASE FIELD.NO = 2
LOOP
ERR = ''
IF NOT(RECORD.ID) THEN
CRT
CRT 'Enter record ID : ': ; INPUT RECORD.ID
END
IF RECORD.ID THEN
READV RECV FROM F.FILE,RECORD.ID,0 ELSE
ERR = RECORD.ID:' does not exist on ':FILE.NAME
GOSUB ERR.HANDLER
RECORD.ID = ''
END
END ELSE
FIELD.NO = 1
FILE.NAME = ''
EXIT
END
FIELD.NO += (NOT(ERR))
UNTIL NOT(ERR) REPEAT
CASE FIELD.NO = 3
CRT
CRT
CRT '[LFORMAT V1.0]'
CRT
LOOP
REMOVE STRING FROM OPT.STRING SETTING MORE
IF STRING THEN CRT STRING
WHILE MORE REPEAT
CRT
PERFORM 'FORMAT ':FILE.NAME:' ':RECORD.ID
READ RECV FROM F.FILE,RECORD.ID THEN NULL
MAX.LINES = DCOUNT(RECV,@FM)
REC(VINCLUDE) = RECV
PTR.WIDTH = ''
PTR.LENGTH = ''
PTR.TOP.MAR = ''
PTR.BOT.MAR = ''
PTR.MODE = ''
PTR.OPTIONS = ''
CALL !SET.PTR(-1,PTR.WIDTH,PTR.LENGTH,PTR.TOP.MAR,PTR.BOT.MAR,PTR.MODE,PTR.OPTIONS)
IF LANDSCAPE THEN
CALL !SET.PTR(0,92,99,0,0,3,'BANNER ':RECORD.ID:@USERNO:',NHEAD')
PRINTER.WIDTH = 92-9
END ELSE
CALL !SET.PTR(0,129,PORT.LINES,0,0,PTR.MODE,PTR.OPTIONS)
PRINTER.WIDTH = 129 - 9
END
PRINTER ON
IF NOT(LANDSCAPE) THEN
PRINT ESC:'&l0O':COND:LPI
HEADING "File, Record = ":FILE.NAME:", ":RECORD.ID:"'G'Acc. - ":@WHO:"'GTG'Dev. - ":FIELD(@LOGNAME,'\',2):"'G'Page 'SL'":STR(CHAR(205),129)
END
INDENT = 0
CNT = 0
AMT(VINCLUDE) = MAX.LINES
GRAND.TOT = AMT(VINCLUDE)
CRT STR(@(-10),INT(((AMT(VINCLUDE)/10)[[/TERM]].WIDTH) + 1) + 2):@(-4):'Performing a Lineup Format ...':@(-3)
GOSUB PROCESS.REC
IF LANDSCAPE THEN
FIELD.NO = 4
END ELSE
FIELD.NO = 5
END
CASE FIELD.NO = 4
PRINTER CLOSE
PRINTER OFF
CALL !SET.PTR(0,188,LINES.PER.COL + 2,0,0,PTR.MODE,PTR.OPTIONS)
PRINTER ON
PRINT ESC:'&l1O':COND:LPI
HEADING "File Name - ":FILE.NAME:"'G'Record Name - ":RECORD.ID:"'G'Account - ":@WHO:"'G'Date and Time - 'TG'Developer - ":FIELD(@LOGNAME,'\',2):"'G'Page 'SL'":STR(CHAR(205),188)
READ HOLD.REC FROM F.HOLD,RECORD.ID:@USERNO THEN
* DELETE F.HOLD,RECORD.ID:@USERNO
HOLD.TOT = DCOUNT(HOLD.REC,@FM)
FOR CNT = 1 TO HOLD.TOT STEP LINES.PER.PAGE
FOR X = CNT TO CNT+(LINES.PER.COL-1)
PRINT FMT(HOLD.REC<X>,'92L'):' ':CHAR(221):' ':FMT(HOLD.REC<X+LINES.PER.COL>,'92L')
NEXT X
NEXT CNT
END ELSE
PRINT "Couldn't read ":RECORD.ID:@USERNO:" from &HOLD&"
END
FIELD.NO = 5
CASE FIELD.NO = 5
PRINTER CLOSE
PRINTER OFF
CRT
IF START.LINE AND END.LINE NE 999999 THEN
CRT 'Lines ':START.LINE:' to ':END.LINE:' printed to unit 0'
END ELSE
CRT GRAND.TOT:' lines printed to unit 0'
END
CALL !SET.PTR(0,PTR.WIDTH,PTR.LENGTH,PTR.TOP.MAR,PTR.BOT.MAR,PTR.MODE,PTR.OPTIONS)
FIELD.NO = 99
END CASE
UNTIL FIELD.NO = 99 REPEAT
WHILE MORE.IDS REPEAT
CRT
STOP
PROCESS.REC:
LOOP
CNT += 1
IF NOT(MOD(CNT,10)) THEN
CRT ">":
END
REMOVE LINE FROM REC(VINCLUDE) SETTING MORE
IF NOT(VINCLUDE) THEN
IF CNT LT START.LINE OR CNT GT END.LINE THEN
IF NOT(MORE) THEN EXIT ELSE CONTINUE
END
END
LINE.NO = FMT(CNT,"4'0'R"):(IF VINCLUDE THEN "$:" ELSE ": "):" "
TEST = TRIM(LINE)
FLINE = TRIMF(LINE)
LINE.LEN = LEN(LINE)
IF LEN(TEST) = 0 THEN
PRINT LINE.NO:MASK[1,INDENT]
END ELSE
INDENT = LINE.LEN - LEN(FLINE)
LINE = MASK[1, INDENT]:FLINE
FOR XX = 1 TO LINE.LEN STEP PRINTER.WIDTH
PRINT (IF XX = 1 THEN LINE.NO ELSE SPACE(7)):LINE[XX,PRINTER.WIDTH]
NEXT XX
END
IF LINE[1,8] = "$INCLUDE" AND ANS NE "S" THEN
IF ANS NE "E" THEN
CRT
LOOP
CRT 'Expand ':LINE
PREV.ANS = ANS
CRT '(Y)es, (N)o, (E)xpand all, (S)kip all : ':ANS:@(-9): ; INPUT ANS,1
IF ANS = '' THEN ANS = PREV.ANS
ANS = UPCASE(ANS)
UNTIL ANS MATCHES 'Y':@VM:'N':@VM:'E':@VM:'S' DO
CRT @SYS.BELL:
REPEAT
END
IF ANS = 'Y' OR ANS = 'E' THEN
SAVE.CNT(VINCLUDE) = CNT
SAVE.MORE(VINCLUDE) = MORE
SAVE.INDENT(VINCLUDE) = INDENT
CNT = 0
RECORD.ID = FIELD(LINE,' ',3)
IF RECORD.ID = '' THEN
RECORD.ID = FIELD(LINE,' ',2)
END ELSE
FILE.NAME = FIELD(LINE,' ',2)
END
HUSH ON ; PRINTER OFF
PERFORM 'FORMAT ' : FILE.NAME:' ':RECORD.ID
PRINTER ON ; HUSH OFF
RECV = TRANS(FILE.NAME,RECORD.ID,-1,'X')
VINCLUDE += 1
REC(VINCLUDE) = RECV
AMT(VINCLUDE) = DCOUNT(REC(VINCLUDE),@FM)
INDENT = 0
GRAND.TOT += AMT(VINCLUDE)
GOSUB PROCESS.REC
VINCLUDE -= 1
CNT = SAVE.CNT(VINCLUDE)
MORE = SAVE.MORE(VINCLUDE)
INDENT = SAVE.INDENT(VINCLUDE)
END
END
WHILE MORE REPEAT
RETURN
ERR.HANDLER:
CRT
CRT @SYS.BELL:'LFORMAT> ':ERR
CRT
RETURN
END
