From:	MERC::"uunet!WKUVX1.BITNET!DSJ-Mgr" 21-DEC-1992 09:16:02.16
To:	galaxy::gleeve
CC:	
Subj:	OCTOBER92.OUTPUT

$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_UNPACK_VERIFY"))'
$!
$! This archive created by VMS_SHARE Version 8.1
$!   On  6-OCT-1992 12:26:48.27   By user GOATHUNTER   (@WKUVX1.BITNET)
$!
$! The VMS_SHARE software that created this archive
$!    was written by  Andy Harper, Kings College London UK
$!    -- September 1992
$!
$! Credit is due to these people for their original ideas:
$!    James Gray, Michael Bednarek
$!
$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
$!
$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
$!       1. [.OUTPUT]OUTPUT.MAR;1
$!
$set="set"
$set symbol/scope=(nolocal,noglobal)
$f=f$parse("SHARE_UNPACK_TEMP","SYS$SCRATCH:."+f$getjpi("","PID"))
$e="write sys$error  ""%UNPACK"", "
$w="write sys$output ""%UNPACK"", "
$ if .not. f$trnlnm("SHARE_UNPACK_LOG") then $ w = "!"
$ ve=f$getsyi("version")
$ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto start
$ e "-E-OLDVER, Must run at least VMS 4.4"
$ v=f$verify(v)
$ exit 44
$unpack: subroutine ! P1=filename, P2=checksum, P3=attributes
$ if f$search(P1) .eqs. "" then $ goto file_absent
$ e "-W-EXISTS, File ''P1' exists. Skipped."
$ delete 'f'*
$ exit
$file_absent:
$ if f$parse(P1) .nes. "" then $ goto dirok
$ dn=f$parse(P1,,,"DIRECTORY")
$ w "-I-CREDIR, Creating directory ''dn'"
$ create/dir 'dn'
$ if $status then $ goto dirok
$ e "-E-CREDIRFAIL, Unable to create ''dn' File skipped."
$ delete 'f'*
$ exit
$dirok:
$ w "-I-UNPACK, Unpacking file ''P1'"
$ n=P1
$ if P3 .nes. "" then $ n=f
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='n'
PROCEDURE GetHex LOCAL x1,x2;x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,
ERASE_CHARACTER(1))-1;RETURN 16*x1+x2;ENDPROCEDURE;
PROCEDURE SkipPartsep LOOP EXITIF INDEX(ERASE_LINE,"-+-+-+-+-+-+-+-+")=1;
ENDLOOP;ENDPROCEDURE;
PROCEDURE ExpandChar CASE CURRENT_CHARACTER FROM ' ' TO 'z' ["`"]
:ERASE_CHARACTER(1);COPY_TEXT(ASCII(GetHex));[" "]:ERASE_CHARACTER(1);[
OUTRANGE,INRANGE]:MOVE_HORIZONTAL(1);ENDCASE;ENDPROCEDURE;
PROCEDURE ProcessLine s:=ERASE_CHARACTER(1);LOOP EXITIF CURRENT_OFFSET>=LENGTH(
CURRENT_LINE);ExpandChar;ENDLOOP;IF s="V" THEN APPEND_LINE;ENDIF;ENDPROCEDURE;
PROCEDURE AdvanceLine MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);
ENDPROCEDURE;PROCEDURE Decode POSITION(BEGINNING_OF(b));LOOP EXITIF MARK(NONE)=
END_OF(b);IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+-")=1 THEN SkipPartSep;
ELSE ProcessLine;AdvanceLine;ENDIF;ENDLOOP;ENDPROCEDURE;SET(FACILITY_NAME,
"UNPACK");SET(SUCCESS,OFF);SET(INFORMATIONAL,OFF);t:="0123456789ABCDEF";f:=
GET_INFO(COMMAND_LINE,"file_name");b:=CREATE_BUFFER(f,f);Decode;WRITE_FILE(b,
GET_INFO(COMMAND_LINE,"output_file"));QUIT;
$ if p3 .eqs. "" then $ goto dl
$ open/write fdl &f
$ write fdl "RECORD"
$ write fdl P3
$ close fdl
$ w "-I-CONVRFM, Converting record format to ", P3
$ convert/fdl=&f &f-1 &P1
$dl: delete 'f'*
$ if P2 .eqs. "" then $ goto ckskip
$ checksum 'P1'
$ if checksum$checksum .nes. P2 then $ -
  e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ exit
$ckskip: e "-W-CHKSUMSKIP, checksum validation unavailable for ''P1'"
$ endsubroutine
$start:
$!
$ create 'f'
X;++
X;
X;`20`20Macro:`09OUTPUT
X;
X;`20`20Author:`09Hunter`20Goatley,`20goathunter@WKUVX1.BITNET
X;
X;`20`20Functional`20description:
X;
X;`09This`20macro`20will`20cause`20a`20string`20to`20be`20printed`20to`20SYS$OU
VTPUT`20by
X;`09storing`20the`20string`20as`20an`20ASCID`20string`20and`20generating`20a
V`20CALLS
X;`09to`20LIB$PUT_OUTPUT.`20`20The`20ASCID`20strings`20are`20stored`20in`20a
V`20psect
X;`09named`20RO_DEBUG_DATA.
X;
X;`20`20Formal`20parameters:
X;
X;`09STRING`09`09-`20The`20string`20to`20be`20written`20to`20SYS$OUTPUT
X;
X;`20`20Sample`20call:
X;
X;`09OUTPUT`09<This`20is`20a`20debug`20message>
X;
X;--
X`09.MACRO`09OUTPUT`09STRING,?TEXT`09`09`09;*`20Macro`20to`20print`20text;
X`09;;
X`09;`20Save`20the`20current`20code`20psect`20context;
X`09;;
X`09.SAVE_PSECT`20LOCAL_BLOCK`09`09`09`09;*`20Save`20this`20PSECT;
X`09;;
X`09;`20`20Now`20switch`20to`20the`20data`20psect;
X`09;;
X`09.PSECT`09_RO_DEBUG_DATA,NOEXE,WRT,LONG,SHR`09;*`20Change`20to`20data`20PSEC
VT;
X`09;;
X`09;`20`20Align`20the`20string`20on`20a`20longword`20boundary`20and`20create
V`20it`20as`20an
X`09;`20`20ASCID`20string.;
X`09;;
X`09.ALIGN`09LONG`09`09`09`09`09;*`20Align`20on`20longword;
X`20TEXT:`09.ASCID`09`7ESTRING`7E`09`09`09`09;*`20Create`20.ASCID`20string;
X`09;;
X`09;`20`20Because`20TEXT`20is`20a`20local`20label,`20save`20the`20current`20po
Vinter;
X`09;;
X`09..OUTPUT_TEXT`20=`20TEXT`09`09`09`09;*`20Save`20the`20address;
X`09;;
X`09;`20`20Now`20move`20back`20to`20the`20code`20psect`20and`20generate`20the
V`20CALLS`20to;
X`09;`20`20LIB$PUT_OUTPUT;
X`09;;
X`09.RESTORE_PSECT`09`09`09`09`09;*`20Go`20back`20to`20code;
X`09PUSHAQ`09..OUTPUT_TEXT`09`09`09`09;`20Write`20the`20string;
X`09CALLS`09#1,G`5ELIB$PUT_OUTPUT`09`09`09;`20...`20to`20SYS$OUTPUT;
X`09.ENDM`09OUTPUT`09`09`09`09`09;*`20End`20of`20OUTPUT`20macro;
$ call unpack [.OUTPUT]OUTPUT.MAR;1 1158677643 ""
$ v=f$verify(v)
$ exit