$! ------------------ CUT HERE ----------------------- $ v='f$verify(f$trnlnm("SHARE_VERIFY"))' $! $! This archive created by VMS_SHARE Version 7.2-007 22-FEB-1990 $! On 26-MAY-1992 17:15:53.12 By user MASLIB $! $! This VMS_SHARE Written by: $! Andy Harper, Kings College London UK $! $! Acknowledgements to: $! James Gray - Original VMS_SHARE $! Michael Bednarek - Original Concept and implementation $! $!+ THIS PACKAGE DISTRIBUTED IN 14 PARTS, TO KEEP EACH PART $! BELOW 30 BLOCKS $! $! 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. M1.PAS;1 $! 2. M10.PAS;1 $! 3. M2.PAS;1 $! 4. M3.PAS;1 $! 5. M4.PAS;1 $! 6. M5.PAS;1 $! 7. M6.PAS;1 $! 8. M7.PAS;1 $! 9. M7_2.PAS;1 $! 10. M7_3.PAS;1 $! 11. M9.PAS;1 $! 12. M9_2.PAS;1 $! 13. MON.PAS;1 $! 14. XBUILD.COM;6 $! 15. XLINK.COM;1 $! 16. XPAS.COM;1 $! $set="set" $set symbol/scope=(nolocal,noglobal) $f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID")) $e="write sys$error ""%UNPACK"", " $w="write sys$output ""%UNPACK"", " $ if f$trnlnm("SHARE_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 $ 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-PROCESS, Processing file ''P1'." $ if .not. f$verify() then $ define/user sys$output nl: $ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1' PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET( SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:= CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b)); LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION( BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1); IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE; MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1; ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")= 1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF"; POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r); ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1; COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE, "output_file"));ENDPROCEDURE;Unpacker;QUIT; $ delete/nolog 'f'* $ CHECKSUM 'P1' $ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT $ e "-E-CHKSMFAIL, Checksum of ''P1' failed." $ ENDSUBROUTINE $START: $ create 'f' X`5BInherit('Sys$Library:Starlet', X 'Sys$Library:Pascal$Smg_Routines', X 'Sys$Library:Pascal$Lib_Routines', X 'Sys$Library:Pascal$Mth_Routines'), X Environment('M1')`5D X XModule M1; X XConst X DivLine = '---------------------------------------'; X (*1234567890123456789012345678901234567890*) XType X Short_String_Type = Varying`5B20`5D Of Char; X String_Type = Varying`5B80`5D Of Char; X Long_String_Type = Varying`5B256`5D Of Char; X X $Byte = `5BByte`5D -128..127; X $Word = `5BWord`5D -32768..32767; X $UByte = `5BByte`5D 0..255; X $UWord = `5BWord`5D 0..65535; X $ULong = `5BLong`5D Unsigned; X X $UQuad = Record X Q1, Q2 : $ULong; X End; X X X`5BHidden`5D XVar X Seed : Unsigned; X OutChan : $UWord; X Kbd_Id : Unsigned; X InLine : Long_String_Type := ''; X Prompt : String_Type := ''; X PrnPrompt : Boolean := True; X InputFromFile : Boolean := False; X OutputToFile : Boolean := False; X InputFile : Text; X OutputFile : Text; X TimerContext : Unsigned; X X`5BExternal, Hidden`5D XProcedure Driver; External; X XProcedure SysCall( S : `5BUnsafe`5D Unsigned ); XBegin X If Not Odd(S) Then Lib$Signal(S); XEnd; X XProcedure Wait(Sec : Real); XBegin X SysCall( Lib$Wait(Sec) ); XEnd; X XFunction Rnd(Max : $UWord): $UWord; XBegin X Rnd := Round(Mth$Random(Seed)*Max); XEnd; X X(* String function *) X XFunction LowCase(S : String_Type): String_Type; XVar I : $UWord; XBegin X If S.Length > 0 Then For I := 1 To S.Length Do X If S`5BI`5D In `5B'A'..'Z'`5D Then X S`5BI`5D := Chr(Ord('a') + ( Ord(S`5BI`5D) - Ord('A') )); X LowCase := S; XEnd; X XFunction PadStr(S : String_Type; Pos : $UWord): String_Type; XVar I : $UWord; XBegin X If S.Length < Pos Then For I := S.Length + 1 To Pos Do X S := S + ' '; X PadStr := S; XEnd; X XFunction Slead(S : String_Type): String_Type; XVar I : $UWord; Done : Boolean := False; XBegin X I := 0; X While Not Done Do Begin X I := I + 1; X If I > S.Length Then Done := True X Else Done := ( (S`5BI`5D <> ' ') And (S`5BI`5D <> Chr(9)) ); X End; X If I > S.Length Then Slead := '' X Else Slead := Substr(S, I, S.Length - I + 1); XEnd; X XFunction Trim(S : String_Type): String_Type; XVar I : $UWord; Done : Boolean := False; XBegin X I := S.Length + 1; X While Not Done Do Begin X I := I - 1; X If I = 0 Then Done := True X Else Done := ( (S`5BI`5D <> ' ') And (S`5BI`5D <> Chr(9)) ); X End; X If I = 0 Then Trim := '' X Else Trim := Substr(S, 1, I); XEnd; X XFunction Bite(Var S : String_Type; I : $UWord := 0): String_Type; XVar Done : Boolean := False; XBegin X While Not Done Do Begin X I := I + 1; X If I > S.Length Then Done := True X Else Done := (S`5BI`5D = ' '); X End; X If I > S.Length Then Begin X Bite := S; S := ''; End X Else Begin X Bite := Slead(Trim(Substr(S, 1, I))); X S := Slead(Trim(Substr(S, I+1, S.Length - I))); X End; XEnd; X X`5BHidden`5D XFunction ParseStr(S : String_Type; S1 : String_Type; Var Pos : $UWord; X Var Exact : Boolean): Boolean; XVar Done, Term : Boolean := False; XBegin X S := LowCase(S); S1 := LowCase(S1); Pos := 1; X If (S.Length = 0) Or (S1.Length = 0) Then Begin X ParseStr := False; Pos := 0; Exact := False; End X Else While Not Done Do X If (Pos > S1.Length) Then Begin (* parse exact *) X Done := True; ParseStr := True; Pos := Pos - 1; Exact := True; End X Else If (Pos > S.Length) Then Begin (* parse match *) X Done := True; ParseStr := True; Pos := Pos - 1; Exact := False; End X Else If (S`5BPos`5D <> S1`5BPos`5D) Then Begin (* maybe, maybe not *) X Done := True; X If (S`5BPos`5D = ' ') Then Begin (* match *) X ParseStr := True; Pos := Pos - 1; Exact := False; End X Else If Term Then Begin (* match *) X ParseStr := True; Pos := Pos - 2; Exact := False; End X Else Begin (* no match *) X ParseStr := False; Pos := Pos - 1; Exact := False; X End; End X Else Begin (* keep going *) X Term := (S`5BPos`5D = ' '); Pos := Pos + 1; End; XEnd; X XFunction ParseLine(Var S1 : String_Type; Var Index : $UWord; X IsFirst : Boolean := False; IsLast : Boolean := False): Boolean; XVar S : `5BStatic`5D String_Type; Log, Pos, NewPos : `5BStatic`5D $UWord; X FoundOne, FoundExact, Exact : `5BStatic`5D Boolean; XBegin X If IsFirst Then Begin (* first call *) X S := S1; Log := 0; Pos := 0; NewPos := 0; FoundOne := False; X FoundExact := False; Exact := False; ParseLine := False; End X Else If IsLast Then Begin (* last call *) X If FoundOne Then Begin X Bite(S1, Pos); Index := Log; ParseLine := True; End X Else Begin X S1 := ''; Index := 0; ParseLine := False; X End; End X Else If ParseStr(S, S1, NewPos, Exact) Then Begin (* parsing *) X If Not FoundOne Then Begin (* first found *) X Log := Index; FoundOne := True; X FoundExact := Exact; Pos := NewPos; End X Else If (NewPos > Pos) Then Begin (* more likely match *) X Log := Index; FoundExact := Exact; Pos := NewPos; End X Else If (NewPos = Pos) And X (Exact And Not FoundExact) Then Begin (* exact match *) X Log := Index; FoundExact := True; End; X ParseLine := False; X End; XEnd; X XFunction ParseTable(Table : Array`5BLower..Upper: Integer`5D Of Short_String V_Type; X Var S : String_Type; Var Index : $UWord): Boolean; XVar I, N : $UWord; Tmp : String_Type; XBegin X ParseLine(S, Index, TRUE, FALSE); X For I := Lower To Upper Do Begin X Tmp := Table`5BI`5D; N := I; ParseLine(Tmp, N); X End; X ParseTable := ParseLine(S, Index, FALSE, TRUE); XEnd; X XFunction NumberW(Var S : String_Type): $UWord; XVar I, Num : $UWord; Head : String_Type; XBegin X I := Index(S, ' '); X If (I > 1) Then Begin X Head := Trim(SubStr(S, 1, I)); X S := Slead(SubStr(S, I, S.Length - I + 1)); End X Else Begin X Head := S; S := ''; X End; X ReadV(Head, Num, Error := Continue); X NumberW := Num; XEnd; X XFunction NumberI(Var S : String_Type): Integer; XVar I, Num : Integer; Head : String_Type; XBegin X I := Index(S, ' '); X If (I > 1) Then Begin X Head := Trim(SubStr(S, 1, I)); X S := Slead(SubStr(S, I, S.Length - I + 1)); End X Else Begin X Head := S; S := ''; X End; X ReadV(Head, Num, Error := Continue); X NumberI := Num; XEnd; X X(* Screen management function *) X XProcedure PutLine(S : Long_String_Type; ExtraLine : $UWord := 0); XVar Msg : Packed Array`5B1..256`5D Of Char; Len, I : $UWord; XBegin X If OutputToFile Then X Writeln(OutputFile, S, Error := Continue); X If (ExtraLine > 0) Then For I := 1 To ExtraLine Do X S := S + Chr(13) + Chr(10); X Msg := Chr(13) + Chr(10) + S; Len := Length(s) + 2; X SysCall( $Qiow(, OutChan, IO$_WRITEVBLK,,,, Msg, Len,,,,) ); X PrnPrompt := True; XEnd; X X`5BHidden`5D XProcedure PutChars(S : Long_String_Type); XVar Msg : Packed Array`5B1..256`5D Of Char; Len : $UWord; XBegin X Msg := S; Len := Length(S); X SysCall( $Qiow(, OutChan, IO$_WRITEVBLK,,,, Msg, Len,,,,) ); XEnd; X X`5BHidden`5D XFunction KeyGet : Char; XVar Term : `5BStatic`5D $UWord := 0; XBegin X If PrnPrompt Then Begin X PutChars(Chr(13)+Chr(10)+Prompt+InLine); PrnPrompt := False; X End; X If ( Smg$Read_Keystroke(Kbd_Id, Term,, 0,,,) Mod 2 ) = 0 Then KeyGet := Ch Vr(0) X Else KeyGet := Chr(Term); XEnd; X X`5BHidden`5D XFunction KeyStroke : Char; XVar Ch : Char; XBegin X Ch := KeyGet; X While Ch = Chr(0) Do Begin X Driver; Wait(0.1); Ch := KeyGet; X End; X KeyStroke := Ch; XEnd; X X`5BHidden`5D `20 XProcedure Grab_Line_Prime(Var S : String_Type); XVar Ch : Char; XBegin X PrnPrompt := True; X Ch := KeyStroke; X While (Ch <> Chr(13)) And (Length(InLine) < 72) Do Begin X If (Ch = Chr(8)) Or (Ch = Chr(127)) Then Begin (* Delete character V *) X If InLine.Length = 1 Then Begin X InLine := ''; PutChars(Chr(8)+' '+Chr(8)); End X Else If InLine.Length > 1 Then Begin X InLine := Substr(InLine, 1, InLine.Length-1); X PutChars(Chr(8)+' '+Chr(8)); X End; End X Else if Ch = Chr(21) Then Begin (* Delete line *) X InLine := ''; PutChars(Chr(13)+Chr(27)+'`5BK'+Prompt); End X Else If ((Ord(Ch)>31) And (Ord(Ch)<127)) Then Begin (* Default *) X InLine := InLine + Ch; PutChars(Ch); X End; X Ch := KeyStroke; X End; X PutChars(Chr(13)); PrnPrompt := True; S := InLine; X If OutputToFile Then Writeln(OutputFile, Prompt+InLine, Error := Continue) V; X InLine := ''; XEnd; X X(* Input/Output function *) X X`5BHidden`5D XFunction ReadFromFile(Var S : String_Type): Boolean; XVar Done, ReadIn : Boolean := False; XBegin X Done := Eof(InputFile); X While Not Done Do Begin X ReadLn(InputFile, S); X If (S.Length = 0) Then ReadIn := False X Else If (S`5B1`5D <> ';') Then ReadIn := True X Else ReadIn := False; X Done := ReadIn Or Eof(InputFile); X PutLine('%'+S); X End; X If ReadIn Then ReadFromFile := True X Else Begin X ReadFromFile := False; InputFromFile := False; Close(InputFile); X End; XEnd; X XProcedure GrabLine(NewPrompt : String_Type; Var S : String_Type; X Process : Boolean := True); XBegin X Prompt := NewPrompt; X If (S.Length > 0) Then Driver X Else If Not InputFromFile Then Grab_Line_Prime(S) X Else If Not ReadFromFile(S) Then Grab_Line_Prime(S); X If Process Then S := Slead(Trim(S)); XEnd; X XFunction GrabNumberW(Prompt : String_Type; Var S : String_Type): $UWord; XBegin X While S.Length = 0 Do GrabLine(Prompt, S); X GrabNumberW := NumberW(S); XEnd; X XFunction GrabNumberI(Prompt : String_Type; Var S : String_Type): Integer; XBegin X While S.Length = 0 Do GrabLine(Prompt, S); X GrabNumberI := NumberI(S); XEnd; X XFunction GrabBoolean(Prompt : String_Type; Var S : String_Type): Boolean; XBegin X While S.Length = 0 Do GrabLine(Prompt, S); X If (S`5B1`5D = 'T') Or (S`5B1`5D = 't') Then Begin X GrabBoolean := True; X Bite(S); X End Else Begin X GrabBoolean := False; X S := ''; X End; XEnd; X XFunction GrabShortStr(Prompt : String_Type; Var S : String_Type): Short_Stri Vng_Type; XBegin X While S.Length = 0 Do GrabLine(Prompt, S); X GrabShortStr := Bite(S); XEnd; X XProcedure PrintTable(Table : Array`5BLower..Upper: Integer`5D Of Short_Strin Vg_Type); XVar I : $UWord; Tmp : Long_String_Type := ''; S : String_Type := ''; XBegin X For I := Lower To Upper Do Begin X Tmp := Tmp + PadStr(Table`5BI`5D, 21); X If Tmp.Length < 80 Then S := Tmp X Else Begin X Putline(S); Tmp := PadStr(Table`5BI`5D, 21); X End; X End; X PutLine(Tmp); XEnd; X XProcedure PrintStr(Str : String_Type := ''); XVar S : `5BStatic`5D String_Type := ''; Tmp : `5BStatic`5D Long_String_Type V := ''; XBegin X If Str.Length = 0 Then Begin X Putline(Tmp); S := ''; Tmp := ''; End X Else Begin X Tmp := Tmp + PadStr(Str, 21); X If Tmp.Length < 80 Then S := Tmp X Else Begin X PutLine(S); Tmp := PadStr(Str, 21); X End; X End; XEnd; X XFunction GrabTable(Prompt : String_Type; X Table : Array`5BLower..Upper:Integer`5D Of Short_String_Type; +-+-+-+-+-+-+-+- END OF PART 1 +-+-+-+-+-+-+-+-