$! ------------------ CUT HERE ----------------------- $ v='f$verify(f$trnlnm("SHARE_VERIFY"))' $! $! This archive created by VMS_SHARE Version 7.2-007 22-FEB-1990 $! On 5-APR-1993 21:14:28.75 By user MASMUMMY $! $! 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 8 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. BUILD.COM;1 $! 2. CASE_CONVERT.PAS;1 $! 3. CLEAR.PAS;1 $! 4. CREEFC.PAS;1 $! 5. CRESEC.PAS;1 $! 6. DAY.PAS;1 $! 7. DAYTIME.PAS;1 $! 8. DEBUG.PAS;1 $! 9. DEBUG_FLAG.MAR;1 $! 10. DEC.PAS;1 $! 11. ERROR.PAS;1 $! 12. EXTRACT.PAS;1 $! 13. FORMATTED_READ.PAS;1 $! 14. FULL_CHAR.PAS;1 $! 15. GET_CLEAR.PAS;1 $! 16. GET_JPI.PAS;1 $! 17. GET_POSN.PAS;1 $! 18. HANDLER.PAS;1 $! 19. HEX.PAS;1 $! 20. IMAGEDIR.MAR;1 $! 21. IMAGE_DIR.PAS;1 $! 22. INTERACT.PAS;1 $! 23. MAP.MAR;1 $! 24. POSN.PAS;1 $! 25. QIO_READ.PAS;1 $! 26. QIO_READ_INTEGER.PAS;1 $! 27. QIO_READ_VARYING.PAS;1 $! 28. QIO_WRITE.PAS;1 $! 29. RANDOM.PAS;1 $! 30. RANDOMIZE.PAS;1 $! 31. RESET_SCREEN.PAS;1 $! 32. RMS_STATUS.PAS;1 $! 33. SHOW_GRAPHEDT.PAS;1 $! 34. SIGN.PAS;1 $! 35. SLEEP.MAR;1 $! 36. SLEEP.PAS;1 $! 37. SMART_POSN.PAS;1 $! 38. SQUARE.PAS;1 $! 39. STOPWATCH.PAS;1 $! 40. SWAP.PAS;1 $! 41. SYSCALL.PAS;1 $! 42. TOPTEN.PAS;1 $! 43. TRIM.PAS;1 $! 44. TTIO.MAR;1 $! 45. VT100.PAS;1 $! 46. VT100_ESC_SEQS.PAS;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$! Command file to create the INTERACT and UTIL object libraries. X$! X$ IF P1 .EQS. "UTIL" THEN GOTO UTIL X$! X$! Interact library X$! ---------------- X$! X$ PAS/NOOBJ INTERACT X$ LIBRARY/CREATE INTERACT.OLB X$ MACRO DEBUG_FLAG X$ LIBRARY/INSERT INTERACT.OLB DEBUG_FLAG X$ MACRO MAP X$ LIBRARY/INSERT INTERACT.OLB MAP X$ PAS CRESEC X$ LIBRARY/INSERT INTERACT.OLB CRESEC X$ PAS DAY X$ LIBRARY/INSERT INTERACT.OLB DAY X$ PAS DAYTIME X$ LIBRARY/INSERT INTERACT.OLB DAYTIME X$ PAS DEC X$ LIBRARY/INSERT INTERACT.OLB DEC X$ PAS EXTRACT X$ LIBRARY/INSERT INTERACT.OLB EXTRACT X$ PAS GET_JPI X$ LIBRARY/INSERT INTERACT.OLB GET_JPI X$ PAS HEX X$ LIBRARY/INSERT INTERACT.OLB HEX X$ PAS IMAGE_DIR X$ LIBRARY/INSERT INTERACT.OLB IMAGE_DIR X$ PAS RANDOM X$ LIBRARY/INSERT INTERACT.OLB RANDOM X$ PAS RANDOMIZE X$ LIBRARY/INSERT INTERACT.OLB RANDOMIZE X$ PAS RMS_STATUS X$ LIBRARY/INSERT INTERACT.OLB RMS_STATUS X$ PAS SIGN X$ LIBRARY/INSERT INTERACT.OLB SIGN X$ PAS STOPWATCH X$ LIBRARY/INSERT INTERACT.OLB STOPWATCH X$ PAS SWAP X$ LIBRARY/INSERT INTERACT.OLB SWAP X$ PAS SYSCALL X$ LIBRARY/INSERT INTERACT.OLB SYSCALL X$ PAS TRIM X$ LIBRARY/INSERT INTERACT.OLB TRIM X$ PAS VT100 X$ LIBRARY/INSERT INTERACT.OLB VT100 X$ PAS CASE_CONVERT X$ LIBRARY/INSERT INTERACT.OLB CASE_CONVERT X$ PAS ERROR X$ LIBRARY/INSERT INTERACT.OLB ERROR X$ PAS FULL_CHAR X$ LIBRARY/INSERT INTERACT.OLB FULL_CHAR X$ PAS GET_POSN X$ LIBRARY/INSERT INTERACT.OLB GET_POSN X$ PAS CREEFC X$ LIBRARY/INSERT INTERACT.OLB CREEFC X$ PAS HANDLER X$ LIBRARY/INSERT INTERACT.OLB HANDLER X$ PAS DEBUG X$ LIBRARY/INSERT INTERACT.OLB DEBUG X$ PAS QIO_READ X$ LIBRARY/INSERT INTERACT.OLB QIO_READ X$ PAS QIO_WRITE X$ LIBRARY/INSERT INTERACT.OLB QIO_WRITE X$ PAS SLEEP X$ LIBRARY/INSERT INTERACT.OLB SLEEP X$ PAS CLEAR X$ LIBRARY/INSERT INTERACT.OLB CLEAR X$ PAS GET_CLEAR X$ LIBRARY/INSERT INTERACT.OLB GET_CLEAR X$ PAS POSN X$ LIBRARY/INSERT INTERACT.OLB POSN X$ PAS RESET_SCREEN X$ LIBRARY/INSERT INTERACT.OLB RESET_SCREEN X$ PAS SMART_POSN X$ LIBRARY/INSERT INTERACT.OLB SMART_POSN X$ PAS SQUARE X$ LIBRARY/INSERT INTERACT.OLB SQUARE X$ PAS FORMATTED_READ X$ LIBRARY/INSERT INTERACT.OLB FORMATTED_READ X$ PAS QIO_READ_INTEGER X$ LIBRARY/INSERT INTERACT.OLB QIO_READ_INTEGER X$ PAS QIO_READ_VARYING X$ LIBRARY/INSERT INTERACT.OLB QIO_READ_VARYING X$ PAS TOPTEN X$ LIBRARY/INSERT INTERACT.OLB TOPTEN X$ PAS SHOW_GRAPHEDT X$ LIBRARY/INSERT INTERACT.OLB SHOW_GRAPHEDT X$! X$! Util library X$! ------------ X$! X$UTIL: X$ MACRO TTIO X$ MACRO SLEEP X$ MACRO IMAGEDIR X$ LIBRARY/CREATE UTIL.OLB X$ LIBRARY/INSERT UTIL.OLB TTIO,SLEEP,IMAGEDIR X$ SET FILE/TRUNC UTIL.OLB X$! X$! Cleanup X$! X$ DELETE/NOCONFIRM *.OBJ;* X$ DELETE/NOCONFIRM/EXCLUDE=INTERACT.PEN *.PEN;* X$! X$ EXIT $ CALL UNPACK BUILD.COM;1 103776261 $ create 'f' X`5B X Inherit X ('SYS$LIBRARY:STARLET','SYS$LIBRARY:PASCAL$LIB_ROUTINES', X 'SYS$LIBRARY:PASCAL$STR_ROUTINES','VT100'), X Environment X ('CASE_CONVERT.PEN') X`5D X XMODULE CASE_CONVERT; X X`5BHIDDEN`5DTYPE X v_array = varying `5B256`5D of char; X X`5BGLOBAL`5D XFUNCTION Upper_case ( c : char ) : char; XBEGIN X IF ( c in `5B'a'..'z'`5D ) then X c := chr ( ord(c) - ord('a') + ord('A') ); X upper_case := c; XEND; X X`5BGLOBAL`5D XFUNCTION Lower_case ( c : char ) : char; XBEGIN X IF ( c in `5B'A'..'Z'`5D ) then X c := chr ( ord(c) - ord('A') + ord('a') ); X lower_case := c; XEND; X X`5BGLOBAL`5D XFUNCTION Upper_string ( text : v_array ) : v_array; XVAR X ret_status : integer; XBEGIN X ret_status := str$upcase (text.body,text); X IF not odd(ret_status) then X LIB$SIGNAL(ret_status); X upper_string := text; XEND; X X`5BGLOBAL`5D XFUNCTION Lower_string ( text : v_array ) : v_array; XVAR X i : integer; XBEGIN X FOR i := 1 to text.length do X text`5Bi`5D := Lower_case (text`5Bi`5D); X lower_string := text; XEND; X XEND. $ CALL UNPACK CASE_CONVERT.PAS;1 896744224 $ create 'f' X`5B X Inherit`20 X ('VT100','QIO_WRITE','CASE_CONVERT','ERROR'), X Environment`20 X ('CLEAR.PEN')`20 X`5D X XMODULE CLEAR; X X`5BHIDDEN`5D XTYPE X v_array = varying `5B256`5D of char; X X`5BGLOBAL`5D XPROCEDURE Clear ( portiontype : v_array := 'SCREEN'; X cleartype : v_array := 'WHOLETHING' ); XVAR X outline : v_array; XBEGIN X outline := VT100_ESC + '`5B'; X X cleartype := upper_string(cleartype); X IF ( cleartype = 'WHOLETHING' ) then X outline := outline + '2' X ELSE X IF ( cleartype = 'TO_START' ) then X outline := outline + '1' X ELSE X IF ( cleartype <> 'TO_END' ) then X ERROR ('%INTERACT-CLEAR, Cleartype /'+cleartype+'/ Unknown.'); X X portiontype := upper_string(portiontype); X IF ( portiontype = 'SCREEN' ) then X outline := outline + 'J' X ELSE X IF ( portiontype = 'LINE' ) then X outline := outline + 'K' X ELSE X error ('%INTERACT-CLEAR, Portiontype /'+portiontype+'/ unknown.'); X X qio_write (outline); XEND; X XEND. $ CALL UNPACK CLEAR.PAS;1 806555840 $ create 'f' X`5B X Inherit X ('SYS$LIBRARY:STARLET','SYS$LIBRARY:PASCAL$LIB_ROUTINES','ERROR.PEN'), X Environment X ('CREEFC.PEN') X`5D X XMODULE Creefc; X X`5BHIDDEN`5DTYPE X v_array = varying `5B256`5D of char; X X`5BGLOBAL`5D XPROCEDURE Create_event_flag_cluster ( name : v_array; X cluster : v_array := '64-95' ); XVAR X ret_status : integer; X group : integer; XBEGIN X IF ( cluster = '64-95' ) then X group := 64 X ELSE X IF ( cluster = '96-127' ) then X group := 96 X ELSE X ERROR ('%INTERACT-CREATE-EVENT_FLAG_CLUSTER, cluster groups ''64-95'' & V ''96-127'' only.'); X X ret_status := $ascefc (efn:=group,name:=name); X IF not odd(ret_status) then X LIB$SIGNAL(ret_status); XEND; X XEND. $ CALL UNPACK CREEFC.PAS;1 643320936 $ create 'f' X`5B X Inherit X ('SYS$LIBRARY:STARLET','SYS$LIBRARY:PASCAL$LIB_ROUTINES'), X Environment X ('CRESEC.PEN') X`5D X XMODULE Cresec; X X`5BHIDDEN`5DTYPE X v_array = varying `5B256`5D of char; X $DEFTYP = `5BUNSAFE`5D INTEGER; X $DEFPTR = `5BUNSAFE`5D `5E$DEFTYP; X X X`5BGLOBAL`5D XPROCEDURE Create_global_section X ( X Section_name : v_array; X Section_size : integer; X var Section_ptr : $defptr; X var Section_end : `5BTRUNCATE`5D $defptr X ); XCONST X Pagesize = 512; XVAR X ret_status : integer; X Pagecount : integer; X Maprange : Record X First : `5Bunsafe`5D integer; X Last : `5Bunsafe`5D integer; X End; XBEGIN X Pagecount := (section_size + pagesize - 1) div pagesize; X WITH maprange do X BEGIN X First := 0; X Last := %x3fffffff; X END; X Ret_Status := $Crmpsc(gsdnam := section_name,`20 X pagcnt := pagecount, X flags := sec$m_gbl+sec$m_wrt+sec$m_dzro+ X sec$m_expreg+sec$m_pagfil, X inadr := maprange,`20 X retadr := maprange); X If not odd(ret_status) then X LIB$SIGNAL(ret_status); X Section_ptr := maprange.first; X IF Present(Section_end) then X section_end := maprange.last; XEND; X X`5BGLOBAL`5D XPROCEDURE Delete_global_section ( Section_ptr, Section_end : $defptr ); XVAR X ret_status : integer; X Maprange : Record X First : `5Bunsafe`5D integer; X Last : `5Bunsafe`5D integer; X End; XBEGIN X WITH maprange do X BEGIN X First := section_ptr; X Last := section_end; X END; X Ret_Status := $Deltva (maprange); X If not odd(ret_status) then X LIB$SIGNAL(ret_status); XEND; X XEND. $ CALL UNPACK CRESEC.PAS;1 1766418776 $ create 'f' X`5B X Inherit X ('SYS$LIBRARY:STARLET'), X Environment X ('DAY.PEN') X`5D X XMODULE DAY; X X`5BHIDDEN`5DTYPE X v_array = varying `5B256`5D of char; X X`5BGLOBAL`5D XFUNCTION Day_str ( day : integer ) : v_array; XBEGIN X CASE day of X 1 : day_str := 'MON'; X 2 : day_str := 'TUE'; X 3 : day_str := 'WED'; X 4 : day_str := 'THU'; X 5 : day_str := 'FRI'; X 6 : day_str := 'SAT'; X 7 : day_str := 'SUN'; X End; XEND; X XEND. $ CALL UNPACK DAY.PAS;1 809828937 $ create 'f' X`5B X Inherit X ('SYS$LIBRARY:STARLET','SYS$LIBRARY:PASCAL$LIB_ROUTINES'), X Environment X ('DAYTIME.PEN') X`5D X XMODULE DAYTIME; X X`5BHIDDEN`5D XTYPE X $UWORD = `5BWORD`5D 0..65535; X date_time_type = array `5B1..7`5D of $uword; `20 X $QUAD = `5BQUAD,UNSAFE`5D RECORD X L0:UNSIGNED; L1:INTEGER; END; X XVAR X date_time : `5BGLOBAL`5D date_time_type; X X X`5BASYNCHRONOUS, EXTERNAL(LIB$DAY_OF_WEEK)`5D XFUNCTION $Day_of_week X ( X time : $quad := %IMMED 0; X VAR day_num : integer X ) : integer; XExtern; X X X`5BGLOBAL`5D XPROCEDURE Get_Date_time; XVAR X ret_status : integer; XBEGIN X ret_status := $numtim (date_time); X IF not odd(ret_status) then X LIB$SIGNAL(ret_status); XEND; X X X`5BGLOBAL`5D XFUNCTION Day_num : integer; XVAR X temp : integer; X q : $quad; X ret_status : integer; XBEGIN X ret_status := $gettim(q); X IF not odd(ret_status) then X LIB$SIGNAL(ret_status); X ret_status := $day_of_week(q,temp); X IF not odd(ret_status) then X LIB$SIGNAL(ret_status); X day_num := temp; XEND; X XEND. $ CALL UNPACK DAYTIME.PAS;1 1919681261 $ create 'f' X`5B X Inherit X ( X `20 X 'SYS$LIBRARY:STARLET', X 'ERROR', X 'HANDLER', X 'CRESEC', X 'CREEFC' X ), X ENVIRONMENT X ('DEBUG') X`5D X XMODULE Debug (output); X X`5BHIDDEN`5D XCONST X dbg_request = 96; X dbg_reply = 97; X X`5BHIDDEN`5D XTYPE X v_array = varying `5B256`5D of char; X $DEFTYP = `5BUNSAFE`5D INTEGER; X $DEFPTR = `5BUNSAFE`5D `5E$DEFTYP; X XTYPE X debugger_data = Record X exit_please : boolean; X Partner : boolean; X Initialized : boolean; X message_from_partner : boolean; X message_reads : v_array; X CASE request : integer of X 1 : X ( dbg_qio_1_char : char ); X 2 : X ( dbg_qio_write_speed : integer; +-+-+-+-+-+-+-+- END OF PART 1 +-+-+-+-+-+-+-+-