From:	MERC::"uunet!WKUVX1.BITNET!FILESERV-Mgr"  6-JUL-1992 17:17:42.47
To:	galaxy::gleeve
CC:	
Subj:	VMS_SHARE.002-OF-005

-+-+-+-+-+-+-+-+ START OF PART 2 -+-+-+-+-+-+-+-+
X! +                                                                    +
X! +--------------------------------------------------------------------+
X!
X!
X`0C
X! +--------------------------------------------------------------------+
X! + Initialisation routine to set up global constant values            +
X! +--------------------------------------------------------------------+
X
XPROCEDURE Init_Constants;
X
X   FAC_name       := "VMS_SHARE";`09! Facility name/version
X   FAC_vers       := "7.2-011  26-Jun-1992";
X   FAC_unpack     := "UNPACK";`09`09! Facility name of unpack code
X
X   TPU_Max_Record_Length := 960;`09! Max record length TPU supports
X   TPU_separators := "&(),=;>@";`09! Split packed TPU code on these
X
X   Quote_Flag := "`60";`09`09`09! Flag for escaping troublesome chars
X
X   DEBUG_state    := 0;`09`09`09! Turn debugging ON/OFF
X   Max_Line_Length:= 77;`09`09! Maximum length of coded/packed lines
X   Max_Parts      := 999;`09`09! Maximum number of parts supported
X
X   SPLIT_disallowed   := 0;`09`09! Flags for dealing with part breaks
X   SPLIT_permit_goto  := 1;
X   SPLIT_inhibit_goto := 2;
X
X
X!
X! The following define strings used to separate out the parts. They are`20
X! defined like this to make it easier to refer to substrings later in the co
Vde
X!
X   FAO_Flag_Start := "-+-+-+-+-+-+-+-+";
X   FAO_Flag_End   := "+-+-+-+-+-+-+-+-";
X   FAO_Start_Part := FAO_Flag_Start + " START OF PART !UL " + FAO_Flag_Start
V;
X   FAO_End_Part   := FAO_Flag_End   + "  END  OF PART !UL " + FAO_Flag_End;
X   FAO_Flag_Length:= LENGTH(FAO_Flag_Start);
X
X
X!
X! These define special part separators where the split point falls on DCL co
Vde
X! in the packed output file. These strings are used instead of the special
X! ones immediately above in this case.
X!
X   FAO_start_label:= "$PART!UL:";
X   FAO_end_goto   := "$ GOTO PART!UL";`09! Format strings for DCL part separ
Vators
X
X
X!
X! The following define special characters/strings which appear at the start
X! of key lines within user data in the packed output file.
X!
X   Flag_Initial_Line      := "X";`09! Flag first line of a long line
X   Flag_Continuation_Line := "V";`09! Flag continuation lines.
X   Flag_Start             := SUBSTR(FAO_Flag_Start,1,1);
X   Flag_End               := SUBSTR(FAO_Flag_End,  1,1);
X   Flag_Start_Rest        := SUBSTR(FAO_Flag_Start,2,FAO_Flag_Length-1);
X
XENDPROCEDURE;
X`0C
X! +--------------------------------------------------------------------+
X! + Initialisation routine to set up tables                            +
X! +                                                                    +
X! + This routine sets up global tables that are used to perform various+
X! + conversions on the characters in the files:                        +
X! +                                                                    +
X! +    ASCII_CHARS:     A table of ascii characters, used for mapping  +
X! +                     characters into their 'escaped' form.          +
X! +                                                                    +
X! +    NON_PRINTABLES:  A table of characters which have no visible    +
X! +                     representation. Used for determining which     +
X! +                     characters to 'escape'.                        +
X! +                                                                    +
X! +    TROUBLE_CHARS:   Characters which may get randomly converted on +
X! +                     passing thru the network and which therefore   +
X! +                     will need 'escaping'.                          +
X! +                                                                    +
X! +--------------------------------------------------------------------+
X
XPROCEDURE Init_Tables
XLOCAL c;
X
X  c := 0;
X  ascii_chars    := "";`09`09`09! Table of ASCII characters
X  Non_Printables := "";`09`09`09! Table of non-printing chars
X
X  LOOP
X    EXITIF C > 255;
X    ascii_chars := ascii_chars + ASCII(c);
X
X    IF (c < 32) OR (c > 126)
X      THEN
X         Non_Printables := Non_Printables + ASCII(c);
X    ENDIF;
X    c:=c+1;
X  ENDLOOP;
X   `20
X  Trouble_chars :=`09`09`09! Troublesome characters
X                   ASCII(91)`09`09! Left square bracket
X                 + ASCII(93)`09`09! Right square bracket
X                 + ASCII(94)`09`09! Caret
X                 + ASCII(123)`09`09! Left curly bracket
X                 + ASCII(124)`09`09! Vertical bar
X                 + ASCII(125)`09`09! Right curly bracket
X                 + ASCII(126)`09`09! Tilde
X                ;
X
X  Funny_Chars := Non_Printables + Trouble_Chars + Quote_Flag;
X
XENDPROCEDURE;
X`0C
X! +--------------------------------------------------------------------+
X! +                                                                    +
X! +  GENERAL UTILITY ROUTINES:                                         +
X! +                                                                    +
X! +     Inform(Xsev,Xident,Xtext);                                     +
X! +        Output error message in usual VMS format                    +
X! +                                                                    +
X! +     Size_Buffer(Xbuffer);                                          +
X! +        Returns the size in bytes of an arbitrary buffer. The       +
X! +        routine estimates the amount of disk space the buffer       +
X! +        would occupy if written to a file.  Ends of lines count as  +
X! +        three characters here. This is a slight overestimate in     +
X! +        practice but suffices.                                      +
X! +                                                                    +
X! +     Write_Part(Xbuffer,Part);                                      +
X! +        Writes an arbitrary buffer to a file. The current share file+
X! +        name is selected and the current 'part' number appended to  +
X! +        the filename (eg. X.SHARn)                                  +
X! +                                                                    +
X! +     Move_Info(FromBuf,ToBuf);                                      +
X! +        Shorthand for moving all info from one buffer to another    +
X! +                                                                    +
X! +     Copy_Line(Xstring);                                            +
X! +        Adds a string to the current buffer and follows it with a   +
X! +        new line character.                                         +
X! +                                                                    +
X! +     Reuse_Buffer(Xbuffer)                                          +
X! +        Erase buffer contents and position to it.                   +
X! +                                                                    +
X! +                                                                    +
X! +--------------------------------------------------------------------+
X
X
X
XPROCEDURE Inform(Xsev,xident,Xtext)
XLOCAL prefix;
X
X  prefix := "%" + FAC_name + "-" + Xsev + "-" + Xident;
X  MESSAGE( prefix + ", " + Xtext);
X
XENDPROCEDURE;
X
X
X `20
XPROCEDURE Size_Buffer(Xbuffer)
XLOCAL Size_Chars, Size_Lines;
X
X   Size_Chars := LENGTH(CREATE_RANGE(BEGINNING_OF(Xbuffer),END_OF(Xbuffer),N
VONE));
X   Size_Lines := GET_INFO(Xbuffer,"RECORD_COUNT");
X   RETURN( Size_Chars + 3 * Size_Lines );
X
XENDPROCEDURE;
X
X
X
XPROCEDURE Write_Part(Xbuffer,Part)
XLOCAL f,r;
X
XON_ERROR
X  Inform("E","FILWRERR", "Error writing part to file " + f);
XENDON_ERROR;
X
X
X   f := Share_File+FAO("!3ZL",Part) ;
X   WRITE_FILE(Xbuffer,f);
X
X   IF DEBUG_state
X      THEN
X        r := GET_INFO(Xbuffer,"RECORD_COUNT");
X        Inform("I","DBGWRFIL",FAO("!UL line!%S written to !AS.",r,f));
X   ENDIF;
X
XENDPROCEDURE;
X
X
X
XPROCEDURE Move_Info(FromBuf, ToBuf)
X
X   POSITION(ToBuf);   MOVE_TEXT(FromBuf);
X
XENDPROCEDURE;
X
X
X
XPROCEDURE Copy_Line(Xstring)
X
X   COPY_TEXT(Xstring); SPLIT_LINE;
X
XENDPROCEDURE;
X
X
X
XPROCEDURE Reuse_Buffer(Xbuffer);
X
X   ERASE(Xbuffer);
X   POSITION(Xbuffer);
X
XENDPROCEDURE;
X`0C
X! +--------------------------------------------------------------------+
X! + TPU CODE COMPRESSION ROUTINES                                      +
X! +                                                                    +
X! +    Pack_TPU(Xstring);                                              +
X! +       This routine takes a line of TPU code as a parameter and     +
X! +       adds it to the current buffer in a way that minimises        +
X! +       as much redundant information as possible to produce as few  +
X! +       lines as possible.  The compressed code will be added to the +
X! +       output file to perform file decoding/unpacking.              +
X! +                                                                    +
X! +--------------------------------------------------------------------+
X
X
XPROCEDURE Pack_TPU(Xstring)
XLOCAL s,c;
X
X  POSITION(END_OF(CURRENT_BUFFER));
X  MOVE_HORIZONTAL(-1);
X
X  s := Xstring;
X  EDIT(s,TRIM);
X  COPY_TEXT(s);
X
X  c := SUBSTR(s,LENGTH(s),1);
X  IF INDEX(TPU_separators,c) = 0
X    THEN
X      COPY_TEXT(" ");
X  ENDIF;
X
X  LOOP
X    EXITIF CURRENT_OFFSET < Max_Line_Length;
X    MOVE_HORIZONTAL(-1);
X    POSITION( SEARCH( ANY(TPU_separators),REVERSE) );
X  ENDLOOP;
X                       `20
X  IF LENGTH(CURRENT_LINE) > Max_Line_Length
X    THEN
X      MOVE_HORIZONTAL(1);`09! Split just past the separator character
X      SPLIT_LINE;
X  ENDIF;
X
X  IF DEBUG_state
X    THEN
X      Inform("I","DBGPCKTPUCUR","Current line is """ + CURRENT_LINE + """");
X      Inform("I","DBGPCKTPUNEW","New string is   """ + s + """");
X      Inform("I","DBGPCKTPULST","Last char is    """ + c + """");
X  ENDIF;
X
XENDPROCEDURE;
X`0C
X! +--------------------------------------------------------------------+
X! + BUFFER ENCODING ROUTINES                                           +
X! +                                                                    +
X! +    Quote_Character;                                                +
X! +        Replaces the current character by an 'escape sequence'      +
X! +        consisting of a flag character followed by exactly 2 digits +
X! +        where the digits are the hexadecimal value of the ASCII code+
X! +        of the character being replaced.                            +
X! +                                                                    +
X! +        The intention is to change characters which may get altered +
X! +        in transit into something that is likely to pass thru       +
X! +        unchanged. Restoration is effected at the receiving end.    +
X! +                                                                    +
X! +    Quote_Buffer(Xbuffer,p);                                        +
X! +        This routine searches a buffer for a particular pattern     +
X! +        (Usually one of a series of specific characters) and        +
X! +        replaces the first character of that pattern by the 'escape'+
X! +        sequence. This is performed at each occurence of that       +
X! +        pattern in the buffer.                                      +
X! +                                                                    +
X! +    Wrap_Lines(Xbuffer, Max_Length);                                +
X! +        This routine wraps lines longer than a fixed size so that   +
X! +        all lines are less/equal to this size.  To allow rejoining  +
X! +        All lines are prefixed with a flag to indicate an initial   +
X! +        line or a continuation line.                                +
X! +                                                                    +
X! +        The intention here is to anticipate the actions of mailers  +
X! +        which have line limits and preempt their wrapping attempts  +
X! +        which would corrupt the data being transmitted. Doing it    +
X! +        this way, we have control over rejoining them.              +
X! +                                                                    +
X! +--------------------------------------------------------------------+
X
X
X
XPROCEDURE Quote_Character
X
X  COPY_TEXT(Quote_Flag+FAO("!2XL",INDEX(ascii_chars,ERASE_CHARACTER(1))-1));
X
XENDPROCEDURE;
X`0C
XPROCEDURE Quote_Buffer(Xbuffer, p)
XLOCAL r;
X
XON_ERROR
X  IF ERROR = TPU$_STRNOTFOUND THEN RETURN; ENDIF;
XENDON_ERROR;
X
X  POSITION( BEGINNING_OF(Xbuffer) );
X
X  LOOP
X    r := SEARCH(p, FORWARD, EXACT);
X    EXITIF r=0;
X    POSITION(r);
X
X    IF DEBUG_state
X      THEN
X        Inform("I","DBGQUOBEFORE", "Current_Line_before="""+CURRENT_LINE+"""
V");
X    ENDIF;
X
X    IF LENGTH(CURRENT_LINE)+2 > TPU_Max_Record_Length
X      THEN
X        Inform("W","TPULONGREC", "Line overlong, Quoting suppressed");
X        Inform("W","CURLINEIS",  """" + CURRENT_LINE + """");
X        MOVE_HORIZONTAL(-CURRENT_OFFSET);
X        MOVE_VERTICAL(1);
X      ELSE
X        Quote_Character;
X    ENDIF;
X
X    IF DEBUG_state
X      THEN
X        Inform("I","DBGQUOAFTER", "Current_Line_after ="""+CURRENT_LINE+""""
V);
X    ENDIF;
X
X  ENDLOOP;
X
XENDPROCEDURE;
X`0C
XPROCEDURE Wrap_Lines(Xbuffer, Max_Length)
X
X  POSITION( BEGINNING_OF( Xbuffer ) );
X  LOOP
X    EXITIF MARK(NONE) = END_OF( CURRENT_BUFFER );
X
X    COPY_TEXT( Flag_Initial_Line );
X    LOOP
X      EXITIF LENGTH(CURRENT_LINE) <= Max_Length;
X `20
X      ! Find Last non-blank char on line
X      MOVE_HORIZONTAL(Max_Length-1);`20
X      LOOP
X        MOVE_HORIZONTAL(-1);
X        EXITIF (CURRENT_CHARACTER <> " ") OR (CURRENT_OFFSET < 2);
X      ENDLOOP;
X
X      IF DEBUG_state
X        THEN
X          Inform("I","DBGWRPSPLIT","Splitting Line """+CURRENT_LINE+"""");
X          Inform("I","DBGWRPCHAR", "Split char = """+CURRENT_CHARACTER+"""")
V;
X          Inform("I","DBGWRPOFF",  "Offset = " + STR(CURRENT_OFFSET));
X      ENDIF;
X
X      IF CURRENT_OFFSET < 2
X        THEN
X          MOVE_HORIZONTAL(Max_Length-4);
X          Quote_Character;
X        ELSE
X          MOVE_HORIZONTAL(1);
X      ENDIF;
X
X      ! Split line at last non-blank char or at max line length
X      SPLIT_LINE;
X      COPY_TEXT(Flag_Continuation_Line);
X    ENDLOOP;
X`20
X    ! Move to start of next genuine line
X    MOVE_HORIZONTAL(-1);
X    MOVE_VERTICAL(1);
X
X  ENDLOOP;
X
XENDPROCEDURE;
X`0C
X! +--------------------------------------------------------------------+
X! + Routines to create headers and trailers for insertion in share file+
X! +--------------------------------------------------------------------+
X
X                                                 `20
XPROCEDURE Create_Prologue_Head(Xbuffer, Creator, Blocks, Start_File_List)
XLOCAL filecount,file,nextfile;
X
X  Reuse_Buffer(Xbuffer);
X
X  Copy_Line( "$! ------------------ CUT HERE -----------------------");
X  Copy_Line( "$ v='f$verify(f$trnlnm(""SHARE_VERIFY""))'");
X  Copy_Line( "$!" );
X  Copy_Line( "$! This archive created by " + FAC_name + " Version " + FAC_ve
Vrs);
X  Copy_Line( FAO("$!!   On !%D   By user !AS", 0, Creator) );
X  Copy_Line( "$!" );
X  Copy_Line( "$! This " + FAC_name + " Written by:");
X  Copy_Line( "$!    Andy Harper, Kings College London UK");
X  Copy_Line( "$!" );
X  Copy_Line( "$! Acknowledgements to:");
X  Copy_Line( "$!    James Gray       - Original VMS_SHARE");
X  Copy_Line( "$!    Michael Bednarek - Original Concept and implementation")
V;
X  Copy_Line( "$!");
X  Copy_Line( "$!+ THIS PACKAGE DISTRIBUTED IN 999 PARTS, TO KEEP EACH PART")
V;
X  Copy_Line( "$!  BELOW " + STR(Blocks) + " BLOCKS");
X  Copy_Line( "$!");
X  Copy_Line( "$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER")
V;
X  Copy_Line( "$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )");
X  Copy_Line( "$!");
X  Copy_Line( "$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:");
X
X  filecount := 0;
X  nextfile := Start_File_List;
X  LOOP
X     POSITION(nextfile);
X     EXITIF MARK(NONE) = END_OF(CURRENT_BUFFER);
X
X     file := SUBSTR(CURRENT_LINE,1,INDEX(CURRENT_LINE," ")-1);
X     MOVE_VERTICAL(1);
X     nextfile := MARK(NONE);
X
X     POSITION(Xbuffer);
X     filecount := filecount + 1;
X     Copy_Line( FAO("$!!     !3UL. !AS", filecount, file));
X
X     IF DEBUG_state
X        THEN
X          Inform("I","DBGPROADFIL","Adding name """ + file + """ to prologue
V");
X     ENDIF;
X
X  ENDLOOP;
X  POSITION(Xbuffer);
X
X  Copy_Line( "$!");
X  Copy_Line( "$set=""set""");
X  Copy_Line( "$set symbol/scope=(nolocal,noglobal)");
X  Copy_Line( "$f=f$parse(""SHARE_TEMP"",""SYS$SCRATCH:.TMP_""+f$getjpi("""",
V""PID""))");
X  Copy_Line( "$e=""write sys$error  """"%"+FAC_unpack+""""", """);
X  Copy_Line( "$w=""write sys$output """"%"+FAC_unpack+""""", """);
X  Copy_Line( "$ if f$trnlnm(""SHARE_LOG"") then $ w = ""!""");
X  Copy_Line( "$ ve=f$getsyi(""version"")");
X  Copy_Line( "$ if ve-f$extract(0,1,ve) .ges. ""4.4"" then $ goto START");
X  Copy_Line( "$ e ""-E-OLDVER, Must run at least VMS 4.4""");
X  Copy_Line( "$ v=f$verify(v)");
X  Copy_Line( "$ exit 44");
X  Copy_Line( "$UNPACK: SUBROUTINE ! P1=filename, P2=checksum");
X  Copy_Line( "$ x = P1 - f$parse(P1,,,""version"")");
X  Copy_Line( "$ y = f$search(x)");
X  Copy_Line( "$ if y .eqs. """" then $ goto file_absent");
X  Copy_Line( "$ x = f$integer(f$parse(P1,,,""version"")-"";"")");
X  Copy_Line( "$ y = f$integer(f$parse(y,,,""version"")-"";"")");
X  Copy_Line( "$ if x .gt. y then $ goto file_absent");
X  Copy_Line( "$ if f$mode() .eqs. ""INTERACTIVE"" then $ goto file_interacti
Vve");
X  Copy_Line( "$ if x .eq. y then e ""-W-EXISTS, File ''P1' exists. Skipped."
V"");
X  Copy_Line( "$ if x .ne. y then e ""-W-NEWERVERSION, of File ''P1' exists.
V Skipped.""");
X  Copy_Line( "$file_delete:");
X  Copy_Line( "$ delete 'f'*");
X  Copy_Line( "$ exit");
X  Copy_Line( "$file_interactive:");
X  Copy_Line( "$ if x .eq. y then e ""-W-EXISTS, File ''P1' exists.""");
X  Copy_Line( "$ if x .ne. y then e ""-W-NEWERVERSION, of File ''P1' exists."
V"");
X  Copy_Line( "$ read/error=file_delete/end=file_delete-");
X  Copy_Line( "  /prompt=""Create new version `5By/n`5D: "" -");
X  Copy_Line( "  sys$command x");
X  Copy_Line( "$ if .not. x then $ e ""-W-SKIPPED, File ''P1' skipped.""");
X  Copy_Line( "$ if .not. x then $ goto file_delete");
X  Copy_Line( "$ P1 = P1 - f$parse(P1,,,""version"")");
X  Copy_Line( "$file_absent:");
X  Copy_Line( "$ if f$parse(P1) .nes. """" then $ goto dirok");
X  Copy_Line( "$ dn=f$parse(P1,,,""DIRECTORY"")");
X  Copy_Line( "$ w ""-I-CREDIR, Creating directory ''dn'.""");
X  Copy_Line( "$ create/dir 'dn'");
X  Copy_Line( "$ if $status then $ goto dirok");
X  Copy_Line( "$ e ""-E-CREDIRFAIL, Unable to create ''dn'. File skipped.""")
V;
X  Copy_Line( "$ delete 'f'*");
X  Copy_Line( "$ exit");
X  Copy_Line( "$dirok:");
X  Copy_Line( "$ w ""-I-PROCESS, Processing file ''P1'.""");
X  COPY_TEXT( "$ if .not. f$verify() then $ define/user sys$output nl:");
X
XENDPROCEDURE;
X
X
X
XPROCEDURE Create_Prologue_Unpacker(Xbuffer)
X
X  Reuse_Buffer(Xbuffer);
X
X  Copy_Line("$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'");
X
X  Pack_TPU( "PROCEDURE Unpacker" );
X  Pack_TPU( "ON_ERROR" );`09`09`09`09! Trap SEARCH error
X  Pack_TPU( "ENDON_ERROR;" );
X
X  Pack_TPU( "SET(FACILITY_NAME,"""+FAC_unpack+""");" );`09! SETUP
X  Pack_TPU( "SET(SUCCESS,OFF);" );
X  Pack_TPU( "SET(INFORMATIONAL,OFF);" );
X  Pack_TPU( "f:=GET_INFO(COMMAND_LINE,""file_name"");" );
X  Pack_TPU( "b:=CREATE_BUFFER(f,f);" );
X `20
X  Pack_TPU( "p:=SPAN("" "")@r&LINE_END;" );
X  Pack_TPU( "POSITION(BEGINNING_OF(b));" );
X  Pack_TPU( "LOOP" );`09`09`09`09`09! Trailing blank removal
X  Pack_TPU( "   EXITIF SEARCH(p,FORWARD)=0;" );
X  Pack_TPU( "   POSITION(r);" );
X  Pack_TPU( "   ERASE(r);" );
X  Pack_TPU( "ENDLOOP;" );
X
X  Pack_TPU( "POSITION(BEGINNING_OF(b));" );
X  Pack_TPU( "g:=0;" );
X  Pack_TPU( "LOOP" );`09`09`09`09`09! Unwrap lines
X  Pack_TPU( "  EXITIF MARK(NONE)=END_OF(b);" );
X  Pack_TPU( "  x:=ERASE_CHARACTER(1);" );
X  Pack_TPU( "  IF g=0 THEN" );
X  Pack_TPU( "    IF x=""" + Flag_Initial_Line      + """ THEN");
X  Pack_Tpu( "      MOVE_VERTICAL(1);ENDIF;" );
X  Pack_TPU( "    IF x=""" + Flag_Continuation_Line + """ THEN APPEND_LINE;")
V;
X  Pack_TPU( "      MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;"
V );
X  Pack_TPU( "    IF x=""" + Flag_End   + """ THEN g:=1;ERASE_LINE;ENDIF;" );
X  Pack_TPU( "  ELSE" );
X  Pack_TPU( "    IF x=""" + Flag_Start + """ THEN" );
X  Pack_TPU( "      IF INDEX(CURRENT_LINE,"""+Flag_Start_Rest+""")=1 THEN");
X  Pack_TPU( "         g:=0;ENDIF;" );
X  Pack_TPU( "    ENDIF;" );
X  Pack_TPU( "    ERASE_LINE;" );
X  Pack_TPU( "  ENDIF;" );
X  Pack_TPU( "ENDLOOP;" );
X
X  Pack_TPU( "t:=""0123456789ABCDEF"";" );
X  Pack_TPU( "POSITION(BEGINNING_OF(b));" );
X  Pack_TPU( "LOOP" );`09`09`09`09`09! Restore escaped chars
X  Pack_TPU( "  r:=SEARCH(""" + Quote_Flag + """,FORWARD);" );
X  Pack_TPU( "  EXITIF r=0;" );
X  Pack_TPU( "  POSITION(r);" );
X  Pack_TPU( "  ERASE(r);" );
X  Pack_TPU( "  x1:=INDEX(t,ERASE_CHARACTER(1))-1;" );
X  Pack_TPU( "  x2:=INDEX(t,ERASE_CHARACTER(1))-1;" );
X  Pack_TPU( "  COPY_TEXT(ASCII(16*x1+x2));" );
X  Pack_TPU( "ENDLOOP;" );
X
X  Pack_TPU( "WRITE_FILE(b,GET_INFO(COMMAND_LINE,""output_file""));" );
X  Pack_TPU( "ENDPROCEDURE;" );
X
X  Pack_TPU( "Unpacker;");`09`09`09`09! procedure call
X  Pack_TPU( "QUIT;" );    SPLIT_LINE;`09`09`09! EXIT code
X
X  COPY_TEXT("$ delete/nolog 'f'*");
X
XENDPROCEDURE;
X`0C
XPROCEDURE Create_Prologue_Trail(Xbuffer)
X
X  Reuse_Buffer(Xbuffer);
X
X  Copy_Line( "$ CHECKSUM 'P1'");
X  Copy_Line( "$ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT");
X  Copy_Line( "$ e ""-E-CHKSMFAIL, Checksum of ''P1' failed.""");
X  Copy_Line( "$ ENDSUBROUTINE");
X  COPY_TEXT( "$START:");
X
XENDPROCEDURE;
X
X
X
XPROCEDURE Create_File_Header(Xbuffer);
X
X  Reuse_Buffer(Xbuffer);
X  COPY_TEXT("$ create 'f'");
X
XENDPROCEDURE;
X
X
X
XPROCEDURE Create_File(Xbuffer, Filename)
XLOCAL r;
X
XON_ERROR
X  Inform("E","FILRDERR", "Error reading from file " + FileName);
XENDON_ERROR;
X
X  Reuse_Buffer(Xbuffer);
X  READ_FILE(FileName);
X
X  IF DEBUG_state
X    THEN
X      r := GET_INFO(Xbuffer,"RECORD_COUNT");
X      Inform("I","DBGRDFIL",FAO("!UL line!%S read from file !AS",r,FileName)
V);
X  ENDIF;
X
XENDPROCEDURE;
X
X
XPROCEDURE Create_File_Trailer(Xbuffer, Filename, Checksum);
X
X  Reuse_Buffer(Xbuffer);
X  COPY_TEXT("$ CALL UNPACK " + Filename + " " + Checksum);
X
XENDPROCEDURE;
X
X
XPROCEDURE Create_Epilogue(Xbuffer);
X
X  Reuse_Buffer(Xbuffer);
X  Copy_Line("$ v=f$verify(v)");
X  COPY_TEXT("$ EXIT");
X
XENDPROCEDURE;
X`0C
X! +--------------------------------------------------------------------+
X! + PART SPLITTING ROUTINES                                            +
X! +                                                                    +
X! +    Find_Break(Xbuffer,Max_Size)                                    +
X! +       This routine uses a fast binary search algorithm to find the +
X! +       first line in the given buffer which straddles a given break +
X! +       point - I.E. where the size of the buffer up to and including+
X! +       that line would just go over the 'Max_Size' value (bytes).   +
X! +       This allows us to quickly determine where a buffer should be +
X! +       split when chopping up the info into several small parts.    +
X! +                                                                    +
X! +    Insert_Part_Separator(Part,Xendbuf,Xstartbuf,Split_status)      +
X! +       This routine is responsible for choosing the correct part    +
X! +       separator flag to insert at the beginning and end of parts.  +
X! +       Determination is controlled by two factors:-                 +
X! +                                                                    +
X! +         First by the 'split-status' parameter, which determines if +
X! +         a part break is permitted at this time (its not if, for    +
X! +         example, we are currently in the middle of the TPU code    +
X! +         which does the unpacking!) and, if it is, whether DCL      +
X! +         $GOTO's and labels are useable at the breaks.              +
X! +                                                                    +
X! +         Second, the type of part separator is determined by looking+
X! +         at the data in the buffer immediately following the break  +
X! +         point. If it starts with '$' then we are splitting the     +
X! +         buffer at the DCL code which is part of the unpacking      +
X! +         control thus we can use $GOTO and a label.  If not, then   +
X! +         we are in the midst of user data and should use the        +
X! +         special flag lines                                         +
X! +                                                                    +
X! +    Add_to_part(Xbuffer,split-status)                               +
X! +       This takes a buffer of information and adds as much of it    +
X! +       as possible into the current part buffer, in order to fill   +
X! +       it to its maximum size.  The remainder of the buffer is      +
X! +       then copied into the part buffer in similar fashion, and     +
X! +       we repeat until the supply of information is exhausted. Each +
X! +       time the part buffer fills up it is flushed out to disk.     +
X! +       Part 1 is treated separately as the attention message at the +
X! +       head of the part needs to be updated later with the actual   +
X! +       number of parts created. We therefore keep it around until   +
X! +       the end in a separate buffer and flush it to disk at the end.+
X! +                                                                    +
X! +    Flush_buffer(Xbuffer,Part)                                      +
X! +       Flushes the specified buffer to disk if not empty. The name  +
X! +       of the file used is constructed from the original share      +
X! +       file template and the current part number.                   +
X! +                                                                    +
X! +--------------------------------------------------------------------+
X`0C                                              `20
XPROCEDURE Find_Break(Xbuffer,Max_Size)
XLOCAL Low, High, Size, Line_Size, mb, New_Line, Cur_Line;
X
X  IF DEBUG_State
X    THEN
X      Inform("I","DBGFNDBRKMAX","Max free bytes =" + STR(Max_Size));
X  ENDIF;
X
X  Low      := 0;
X  High     := GET_INFO(Xbuffer,"record_count") - 1;
X  Cur_Line := 0;
X
X  mb := BEGINNING_OF(Xbuffer);
X  POSITION(mb);
X
X  ! Special case of an empty buffer
X  IF mb = END_OF(Xbuffer) THEN RETURN(0); ENDIF;
X
X  ! Special case check to ensure at least one line fits in available space
X  IF LENGTH(CURRENT_LINE)+3 > Max_Size THEN RETURN(0); ENDIF;
X
X
X  LOOP
X
X     New_Line := (Low+High) / 2;
X     MOVE_VERTICAL(New_Line-Cur_Line);
X     Cur_Line := New_Line;
X
X     Size:=LENGTH(CREATE_RANGE(mb,MARK(NONE),NONE))+3*Cur_Line;
X     Line_Size := LENGTH(CURRENT_LINE) + 3;
X
X     IF DEBUG_state
X       THEN
X         Inform("I","DBGFNDBRKRNG",FAO("Search range = !UL-!UL",Low,High));
X         Inform("I","DBGFNDBRKCURL",FAO("(!UL) ""!AS""",Cur_line,CURRENT_LIN
VE));
X         Inform("I","DBGFNDBRKSIZE",FAO("Size=!UL, line=!UL",Size,Line_Size)
V);
X     ENDIF;
X
X     EXITIF (Size < Max_Size) AND (Size+Line_Size >= Max_Size);
X
X     IF Size < Max_Size
X       THEN
X         Low := Cur_Line + 1;
X       ELSE
X         High := Cur_Line - 1;
X     ENDIF;
X
X  ENDLOOP;
X
X  MOVE_HORIZONTAL(-1);
X  RETURN( CREATE_RANGE( mb, MARK(NONE), NONE ) );
X
XENDPROCEDURE;
X`0C
XPROCEDURE Insert_Part_Separator(Part, Xendbuf, Xstartbuf, SPLIT_status)
XLOCAL end_text,start_text;
X
X   IF SPLIT_status = SPLIT_disallowed
X     THEN
X       Inform("F","CANTSPLIT","Part split tried where disallowed");
X       EXIT;
X   ENDIF;
X
X   POSITION( BEGINNING_OF(Xstartbuf) );
X
X   IF (CURRENT_CHARACTER = "$") AND (SPLIT_status = SPLIT_permit_goto)
X      THEN`09`09`09! Executable DCL code insert GOTO/label pair
X         end_text  := FAO(FAO_end_goto, Part+1);
X         start_text:= FAO(FAO_start_label, Part+1);
X      ELSE`09`09`09! User data, insert recognizable separators
X         end_text  := FAO(FAO_end_part, Part);
X         start_text:= FAO(FAO_start_part, Part+1);
X   ENDIF;       `20
X
X   Copy_Line(start_text);      MOVE_VERTICAL(-1);
X   POSITION(END_OF(Xendbuf));  COPY_TEXT(end_text);
X
XENDPROCEDURE;
X`0C
XPROCEDURE Add_To_Part(Xbuffer, SPLIT_status)
XLOCAL Size_Xbuffer, Size_part_buf;
X
X  LOOP
X
X    Size_Xbuffer  := Size_Buffer(Xbuffer);
X    Size_part_buf := Size_Buffer(part_buf);`20
X
X    IF DEBUG_state THEN
X       Inform( "I","DBGADPTMAX" ,FAO("     Max_bytes    = !UL",Max_Bytes));
X       Inform( "I","DBGADPTXSIZ",FAO("     Size xbuffer = !UL",Size_Xbuffer)
V);
X       Inform( "I","DBGADPTPSIZ",FAO("     Size part_buf= !UL",Size_part_buf
V));
X    ENDIF;
X
X    EXITIF Size_Xbuffer <= Max_Bytes-Size_part_buf-Reserved;
X
+-+-+-+-+-+-+-+-  END  OF PART 2 +-+-+-+-+-+-+-+-
