$ verify = 'f$verify(f$trnlnm("SHARE_VERIFY"))'	! Set to 1 if verify required
$ display= f$trnlnm("SHARE_DISPLAY")		! Set to 1 to display TPU errs
$ max_part_size = f$integer(f$trnlnm("share_max_part_size"))! Allow the user to override
$
$ FACILITY_NAME = "VMS_SHARE"
$ FACILITY_VERSION = "V06.10 7-FEB-1989"
$!
$ SS$_ABORT=44
$ SET = "SET"
$ SET SYMBOL/SCOPE=( NOLOCAL, NOGLOBAL )
$ ON CONTROL_Y THEN EXIT SS$_ABORT
$ ON ERROR THEN CONTINUE
$!++---------------------------------------------------------------------
$! VMS_SHARE was written by James Gray.
$!
$! James Gray				Gray:OSBUSouth@Xerox.COM
$! Independent Consultant
$! 875 Victor Avenue, #102
$! Inglewood, CA  90302
$! Phone: (213) 412-5086
$!
$!++---------------------------------------------------------------------
$! Substantial rewrites and enhancements by Andy Harper
$!    o deal with trailing blanks
$!    o simplify code
$!    o speed up packing/unpacking algorithms
$!
$! Andy Harper,
$! Computing Centre,
$! Kings College London
$! The Strand,
$! London
$! Phone +44 (0)1 836 5454
$! E-MAIL:  UDAA055 @ OAK.CC.KCL.AC.UK    (UK JANET academic network)
$!
$!++---------------------------------------------------------------------
$! Substantial credit is given to Michael Bednarek who wrote the original
$! VMS_SHAR.
$!
$! Michael Bednarek              u3369429@{murdu.oz.au | ucsvc.dn.mu.oz.au}
$! Institute of Applied Economic -- or --
$!  and Social Research (IAESR) ...{UUNET.UU.NET | seismo.CSS.GOV}!munnari!
$! Melbourne University          {murdu.oz | ucsvc.dn.mu.oz}!u3369429
$! Parkville 3052, Phone : +61 3 344 5744
$! AUSTRALIA
$!
$! The following copyright notice is being left intact since it is unclear
$! whether this extensive rewrite constitutes a new work or is simply a
$! derivation of the original.  Just in case this constitutes a new work,
$! a second copyright notice is included below; in case of conflict on
$! copyrights, the copyright is granted to Michael Bednarek.
$!
$! Copyright (c) 1987, by Michael Bednarek
$! The distribution of this file is unrestricted as long as this notice
$! remains intact.
$! Credits: SLOANE@UKANVAX@BITNET (Bob Sloane) for the idea of
$!          escaping control characters.
$!
$! Copyright © 1988, by James Gray
$! The distribution of this file is unrestricted as long as these notices
$! remain intact.
$!
$!++---------------------------------------------------------------------
$! Usage: @VMS_SHARE file[,file...] sharfile
$!	where:
$!	file[,file...]	are file names, separated by commas, possibly including
$!			wild-card characters, of those files that are to be
$!			packaged.
$!	sharefile	is the resulting self-unpacking archive file.
$!
$! To turn on verification, define the logical name SHARE_VERIFY to have a value
$! of 1.  If it is undefined, or has a null/zero value, then verification is
$! off.  Verification is also off if the user has no read access.
$!
$! The resulting sharefile will be written in as many parts as is necessary
$! to keep the size of any one part from being greater than SHARE_MAX_PART_SIZE. 
$! By default SHARE_MAX_PART_SIZE is 31 blocks.  The user may define a logical
$! name of the same name to override the default.  The minimum
$! SHARE_MAX_PART_SIZE is 8 blocks.
$!
$! The resulting sharefile(s) will have a file type of .n_OF_m if no file type
$! was specified or will have _n_OF_m appended to the file type; this is true
$! even if the sharefile fits in one part.
$!
$! All parts of the sharefile will be within a few characters of the maximum
$! part size.  Input files may (and probably will) be split between parts.
$! To unpack files, simply cut the text preceeding the second dotted line,
$! copy all files into a single file and then execute (@) that file.  Checksums
$! are based on the input files and not on the parts.  It is unnecessary to
$! remove possible garbage characters at the end of each part.
$!
$! Input files can be of any length and can span one or more sharefile parts.
$! (NOTE: This is the original reason for writing this new version.)
$!
$! The TPU unpacking code, while left intact in this file for readability, is
$! packed into 80 (or less) character lines in the sharefile to minimize the
$! size of the sharefile.
$!
$! As with the original VMS_SHAR, this procedure will escape all characters
$! not in the ASCII range blank (0x20 or 32) to ~ (0x7E or 126).
$!
$! Required: VAX/VMS version 4.4 or higher
$!--
$!+
$! Get the user's USERNAME and the parameters if not already specified.
$!-
$ USER = F$EDIT( F$GETJPI( "", "USERNAME" ), "COLLAPSE" )
$ IF F$TRNLNM( "SHARE_REAL_NAME" ) .NES. "" THEN -
	USER = USER + " (" + F$TRNLNM("SHARE_REAL_NAME") + ")"
$ SAY = "WRITE SYS$OUTPUT"
$ SAY FACILITY_NAME, " ", FACILITY_VERSION
$ SAY ""
$ IF P1 .EQS. "" THEN INQUIRE P1 "_File(s) to package"
$ IF P1 .EQS. "" THEN EXIT SS$_ABORT
$ IF P2 .EQS. "" THEN INQUIRE P2 "_SHARE file"
$ IF P2 .EQS. "" THEN EXIT SS$_ABORT
$ FILE_LIST = P1
$ SHARE_FILE = F$PARSE( P2 ) - ";"
$!+
$! Determine the maximum part size to use.
$!-
$ IF MAX_PART_SIZE .LE. 8 THEN MAX_PART_SIZE = 31		!  the maximum size of each part.
$ SAY "SHARE_MAX_PART_SIZE is defined as ", MAX_PART_SIZE, " blocks (", -
	MAX_PART_SIZE * 512, " bytes)."
$!+
$! Scan the list of supplied files to pack making sure that each one can be found.
$!-
$ SAY ""
$ BEL[0,7] = 7
$ INDEX = -1
$ FILE_COUNT = 1
$NEXT_ELEMENT:
$ FILE_COUNT = FILE_COUNT - 1
$ INDEX = INDEX + 1
$ ELEMENT = F$ELEMENT( INDEX, ",", FILE_LIST )
$ IF ELEMENT .EQS. "," THEN GOTO ELEMENTS_DONE
$ PREVIOUS_FILE = "no file"
$NEXT_FILE:
$ FILE_COUNT = FILE_COUNT + 1
$ FILE'FILE_COUNT = F$SEARCH( ELEMENT )
$ IF FILE'FILE_COUNT .EQS. PREVIOUS_FILE THEN GOTO NEXT_ELEMENT
$ IF FILE'FILE_COUNT .NES. "" THEN GOTO LOOK
$ IF PREVIOUS_FILE .EQS. "no file" THEN -
	SAY "%VMS_SHARE-I-FNF, file not found: ", ELEMENT
$ GOTO NEXT_ELEMENT
$LOOK:
$ PREVIOUS_FILE = FILE'FILE_COUNT
$ SAY "Looking at ", File'FILE_COUNT
$ IF F$ELEMENT( 0, ";", FILE'FILE_COUNT ) .NES. SHARE_FILE THEN GOTO NOT_SHARE_FILE
$ SAY "You can't have your SHARE file among the input files!"
$ EXIT SS$_ABORT
$NOT_SHARE_FILE:
$ GOTO NEXT_FILE
$ELEMENTS_DONE:
$!+
$! Check that there is at least one input file.
$!-
$ IF FILE_COUNT .GT. 0 THEN GOTO SOME_FILES
$ SAY "%VMS_SHARE-W-SEARCHFAIL, error searching for ", P1
$ SAY "-VMS_SHARE-E-FNF, file not found.  No file to package.  Nothing done."
$ EXIT SS$_ABORT
$SOME_FILES:
$!+
$! Write the file that will be used as input to TPU.
$!-
$ OPEN/WRITE VMS_SHARE_DUMMY VMS_SHARE_DUMMY.DUMMY
$ WRITE VMS_SHARE_DUMMY """''USER'"" ""''MAX_PART_SIZE'"" ""''FILE_COUNT'"" ""''SHARE_FILE'"""
$ INDEX = 0
$NEXT_NAME:
$ INDEX = INDEX + 1
$ NAME = F$PARSE( FILE'INDEX )
$ SAY "Checksumming ", File'INDEX
$ CHECKSUM 'NAME
$ WRITE VMS_SHARE_DUMMY """''NAME'"" ""''CHECKSUM$CHECKSUM'"""
$ IF INDEX .LT. FILE_COUNT THEN GOTO NEXT_NAME
$ CLOSE VMS_SHARE_DUMMY
$ SAY ""
$ SAY "Packing files into SHARE file(s) ''SHARE_FILE'"
$ SAY ""
$ IF .not. (verify .or. display) THEN $ DEFINE/USER_MODE SYS$OUTPUT NL:
$ EDIT/TPU/COMMAND=SYS$INPUT/NODISPLAY/NOSECTION VMS_SHARE_DUMMY.DUMMY
!=====================================================================
!     V M S _ S H A R E
!
! Function:
!    Take a series of ASCII files and package them into a self-unpacking
!    command procedure that can be sent relatively undamaged thru the
!    electronic mail system.  Once received, the procedure can be run
!    to produce exact copies of the original text files.
!
! Restrictions:
!    File attributes (in particular - record attributes) are not
!    preserved.
!
!    Because it is impossible to provide a line by line protocol with
!    automatic resend of damaged lines, we rely on the mailer to get
!    each line there undamaged. Missing lines cannot be recovered nor
!    can recovery be effected if the DCL or TPU code that controls the
!    unpacking is damaged in any way.
!
!======================================================================


!+
! Generate a pattern that contains all of the ASCII characters except 
! the printable characters in the range 32 to 126. These will be used
! to determine characters which need to be escaped. Also build a string
! containing the complete ASCII set. We use this to generate 'escape'
! sequences.
!
! Because the network performs obscure translations on certain of the 
! printable characters, we add them to the pattern string in order to
! force them to be escaped, thus allowing them to survive the journey across
! hostile systems.
!						Andy Harper, 6-DEC-1988
!-
PROCEDURE INIT_ASCII
LOCAL i_ascii;	! Loop counter to set up strings and ascii codes

   ! String to contain all unprintable or troublesome characters
   s_control := ASCII( 94) + ASCII(123) + ASCII(124) + ASCII(125) + ASCII(126);

   s_ascii := ""; 		! String to contain all ASCII characters
   i_ascii := 0;  		! Loop counter for building the ASCII code patterns

   LOOP

     s_ascii := s_ascii + ASCII( i_ascii );
     IF ( i_ascii < 32 ) OR ( i_ascii > 126 ) THEN
       s_control := s_control + ASCII( i_ascii );
     ENDIF;

     i_ascii := i_ascii + 1;
     EXITIF i_ascii > 255;

   ENDLOOP;

   ! Generate a pattern for ALL control characters or troublesome printables
   pat_control := ANY( s_control );

ENDPROCEDURE;


!+
!  Procedure to add a line of text to the output; a newline is also added.
!-
PROCEDURE __copy_text( ss_string )

  COPY_TEXT( ss_string);
  SPLIT_LINE;

ENDPROCEDURE;


!+
! Returns the buffer pointer of an existing buffer or, if the buffer does not
! exist, returns 0.
!-
PROCEDURE __find_buffer (s_buffer_name)
LOCAL
    b_buffer,		! Buffer pointer.
    b_next_buffer,	! Next buffer from the list of known buffers.
    s_name;		! Uppercase form of the supplied buffer name.


  s_name := s_buffer_name;
  CHANGE_CASE( s_name, UPPER );

  b_next_buffer := GET_INFO( BUFFERS, 'first' );
  LOOP

    EXITIF b_next_buffer = 0;				! No more known buffers
    EXITIF s_name = GET_INFO( b_next_buffer, 'name' );	! The one we want?
    b_next_buffer := GET_INFO( BUFFERS, 'next' );	! Move to next buffer

  ENDLOOP;

  RETURN( b_next_buffer );		! return pointer to buffer or 0
ENDPROCEDURE



!+
! Determine where in the buffer the current part should end, by computing the
! size until we hit the maximum.
!-
PROCEDURE __find_part_end
LOCAL ii_length, ii_line_length;		! Size of lines and part

  MOVE_HORIZONTAL( -CURRENT_OFFSET );
  ii_length := LENGTH( s_part_goto ) + LENGTH( s_part_end ) + LENGTH( s_part_begin ) + LENGTH( s_part_label );

  LOOP
    EXITIF ( MARK( NONE ) = END_OF( b_packed ) ) OR ( ii_length >= i_max_part_bytes );
    ii_line_length := LENGTH( CURRENT_LINE ) + 2;
    IF ( ii_line_length - ( ( ii_line_length / 2 ) * 2 ) ) <> 0
    THEN
      ii_line_length := ii_line_length + 1;
    ENDIF;
    ii_length := ii_length + ii_line_length;
    MOVE_VERTICAL( 1 );
  ENDLOOP;
  IF ii_length >= i_max_part_bytes
  THEN
    MOVE_VERTICAL( -1 );
  ENDIF;

ENDPROCEDURE;




PROCEDURE __get_quoted_string
LOCAL i_offset, ss_string;

  POSITION( END_OF( SEARCH( s_quote, FORWARD, EXACT ) ) );
  MOVE_HORIZONTAL( 1 );
  i_offset := CURRENT_OFFSET;
  POSITION( END_OF( SEARCH( s_quote, FORWARD, EXACT ) ) );
  ss_string := ERASE_CHARACTER( -( CURRENT_OFFSET - i_offset ) );
  COPY_TEXT( ss_string );
  MOVE_HORIZONTAL( 1 );
  RETURN( ss_string );

ENDPROCEDURE;




!+
! Procedure to pack lines of TPU into a small space by removing superfluous
! blanks and newlines chars. We ensure that each line fits into the defined
! maximum line size and is split only upon recognized characters.
!
! Procedure is entered with the character string to be added. The buffer
! remains positioned atthe last character before and after.
!
! Note, no attempt is made to deal with quoted strings even though TPU will
! object if quoted strings are split across lines during unpacking.  It is
! thought that careful programming of the code being packed should stop
! this happening (The simplest method is to avoid the use of pattern
! separators inside quoted strings).
!				Rewritten 24-OCT-1988 by Andy Harper
!-
PROCEDURE __pack_text( ss_string )
LOCAL s_temp, i_temp;
  !+
  ! This is the basic function of the procedure- Compress the spurious blanks
  ! and add the string to the buffer.
  !-
  s_temp := ss_string;
  EDIT( s_temp, TRIM, COMPRESS );	! Remove superfluous blanks
  COPY_TEXT( s_temp );			! Add new string to buffer
  COPY_TEXT( s_blank );			! Add a separator

  

  !+
  ! Find a convenient split point, if necessary.
  !-
  i_temp := CURRENT_OFFSET;
  LOOP

     EXITIF CURRENT_OFFSET <= i_max_line;
     MOVE_HORIZONTAL(-1);
     POSITION( SEARCH( pat_separator, REVERSE, EXACT ) );


     IF CURRENT_OFFSET = i_temp THEN
        MESSAGE("--- INTERNAL VMS_SHARE ERROR --- stuck finding wrap point!");
        MESSAGE("*** LINE: " + CURRENT_LINE );
        MESSAGE("      AT: " + STR(CURRENT_OFFSET) );
     ENDIF;
     EXITIF CURRENT_OFFSET = i_temp;

     i_temp := CURRENT_OFFSET;
  ENDLOOP;
  !+
  ! Exit with current position on the pattern separator at the split-point
  ! (or the end of line if there isnt one!)
  !-



  !+
  ! If we started with a long line, then split it now.
  !-
  IF CURRENT_OFFSET < LENGTH( CURRENT_LINE ) THEN SPLIT_LINE;  ENDIF;



  !+
  ! Finally, reposition at last char in buffer so we are OK for next time.
  !-
  POSITION( END_OF( CURRENT_BUFFER ) );
  MOVE_HORIZONTAL( -1 );

ENDPROCEDURE;



!+
! This procedure erases the current character from the buffer and replaces
! it by an escaped form - `nnn - where nnn is the ascii code of the
! character. nnn is always exactly 3 digits
!						Andy Harper, 19-OCT-1988
!-
PROCEDURE QUOTE_CHAR;

  COPY_TEXT(s_quoting_char+FAO("!3ZL",INDEX(s_ascii,ERASE_CHARACTER(1))-1));

ENDPROCEDURE;




!+
!  This procedure searches the named buffer for a pattern and replaces the
!  first character in that pattern by its 'escaped' form.
!						Andy Harper, 25-OCT-1988
!-
PROCEDURE QUOTE_BUFFER( bb_name, pat_search)
LOCAL r_x;

   !+
   ! We use an error handler here to catch the fact that TPU always
   ! gives an error message if SEARCH fails to find a string, as of
   ! course it will do when the whole buffer has been processed. This
   ! prevents any message being given.
   !-
   ON_ERROR
      IF ERROR = TPU$_STRNOTFOUND THEN RETURN; ENDIF;
      MESSAGE("*** UNEXPECTED ERROR AT LINE " + STR( ERROR_LINE ) );
   ENDON_ERROR;


   POSITION( BEGINNING_OF( bb_name ) );
   LOOP
      r_x := SEARCH( pat_search, FORWARD, EXACT );
      EXITIF r_x = 0;
      POSITION( r_x );
      QUOTE_CHAR;
   ENDLOOP

ENDPROCEDURE;


!+
! Break all lines longer than i_max_line into lines less than or equal to
! i_max_line.
!
! If breaking a line would leave trailing blanks, then carry up to 3 to
! the next line and escape the remaining one on the line. Carrying three
! across, plus the one that is escaped, should leave exactly enough room
! to insert the 4-character escaped blank!  Less than four consecutive
! trailing blanks are carried across to the next line as is.  If there
! are more than four, then carry a maximum of three across and escape the 
! fourth.
!
! With this method, NO line should end with a trailing blank. We can 
! therefore safely trim off any found at the unpacking stage, thus
! confounding mailers that might add them in along the way!
!                                             Andy Harper, 25-OCT-1988
!-

PROCEDURE WRAP_AND_PREFIX_LINES( bb_file )
LOCAL n_c;

  POSITION( BEGINNING_OF( bb_file ) );
  LOOP						! All lines longer than i_max_line
    IF LENGTH( CURRENT_LINE ) > i_max_line THEN	! characters are
      COPY_TEXT( s_long_line );			! prepended with a "V"
      MOVE_HORIZONTAL( i_max_line );
 
      n_c :=4;
      LOOP
        MOVE_HORIZONTAL(-1);			! Backup to test prev char
        EXITIF CURRENT_CHARACTER <> ' ';	! Non-blank found, exit
        n_c := n_c-1;
        EXITIF n_c = 0;				! Tested all we need to?
      ENDLOOP;

      IF n_c = 0 THEN				! If all are blank..
         QUOTE_CHAR;				! Replace first by quoted version
      ELSE
         MOVE_HORIZONTAL(1);			! Reposition after non-blank
      ENDIF;
    						! Remaining blanks carried
    						! over to next line

      SPLIT_LINE;
    ELSE					! Shorter line.
      COPY_TEXT( s_short_line );		! Prepended with a "X".
      MOVE_HORIZONTAL( -1 );			! Reposition to beginning of line.
      MOVE_VERTICAL( 1 );			! Advance to the next line.
    ENDIF;
    EXITIF MARK( NONE ) = END_OF( bb_file );
  ENDLOOP;

ENDPROCEDURE;




!+
! Build the prolog for all parts.  This is not repeated in every part since 
! it is assumed that all parts will be unpacked.  The rationale for this is
! that a file may span more than one part.
!-
PROCEDURE WRITE_SHARE_PROLOG( buff )

   POSITION( BEGINNING_OF( buff) );
   __copy_text( FAO( "$!! !19*. Cut between dotted lines and save. !19*." ) );
   __copy_text( FAO( "$!!!75*." ) );
   __copy_text( FAO( "$!! VAX/VMS archive file created by !AS !AS.", s_facility_name, s_facility_version ) );
   __copy_text( FAO( "$!!" ) );
   __copy_text( FAO( "$!! !AS was written by James Gray (Gray:OSBUSouth@Xerox.COM) from", s_facility_name ) );
   __copy_text( FAO( "$!! VMS_SHAR by Michael Bednarek (U3369429@ucsvc.dn.mu.oz.au)." ) );
   __copy_text( FAO( "$!!" ) );
   __copy_text( FAO( "$!! To unpack, simply save, concatinate all parts into one file and" ) );
   __copy_text( FAO( "$!! execute (@) that file." ) );
   __copy_text( FAO( "$!!" ) );
   __copy_text( FAO( "$!! This archive was created by user !AS", s_user ) );
   __copy_text( FAO( "$!! on !%D.", 0 ) );
   __copy_text( FAO( "$!!" ) );

   MOVE_VERTICAL( -1 );
   m_attention_text := MARK( NONE );
   MOVE_VERTICAL( 1 );

   __copy_text( FAO( "$!! It contains the following !UL file!%S:", i_num_files ) );

   MOVE_VERTICAL( -1 );
   m_note_filename  := MARK( NONE );
   MOVE_VERTICAL( 1 );

ENDPROCEDURE;






!+
! Append the code that will be used to unpack the files.  Note that the TPU
! code will be compressed.
!-
PROCEDURE WRITE_SHARE_UNPACK( buff );

   POSITION( buff );
   __copy_text( "$!" );
   __copy_text( FAO( "$!!!76*=" ) );


   !+
   ! Code to set up and check environment.
   !-
   __copy_text( "$ SET SYMBOL/SCOPE=( NOLOCAL, NOGLOBAL )" );
   __copy_text( "$ VERSION = F$GETSYI( ""VERSION"" )" );
   __copy_text( "$ IF VERSION .GES ""V4.4"" THEN GOTO VERSION_OK" );
   __copy_text( "$ WRITE SYS$OUTPUT ""You are running VMS ''VERSION'; "", -" );
   __copy_text( FAO( "    ""!AS !AS requires VMS V4.4 or higher.""", s_facility_name, s_facility_version ) );
   __copy_text( "$ EXIT 44 ! SS$_ABORT" );
   __copy_text( "$VERSION_OK:" );
   __copy_text( "$ GOTO START" );
   __copy_text( "$!" );


   !+
   ! Start of routine that unpacks a file.
   !-
   __copy_text( "$UNPACK_FILE:" );
   __copy_text( "$ WRITE SYS$OUTPUT ""Creating ''FILE_IS'""" );
   __copy_text( "$ DEFINE/USER_MODE SYS$OUTPUT NL:" );
   __copy_text( "$ EDIT/TPU/COMMAND=SYS$INPUT/NODISPLAY/OUTPUT='FILE_IS'/NOSECTION -" );
   __copy_text( "    VMS_SHARE_DUMMY.DUMMY" );


   !+
   ! Set up buffers used during unpacking.
   !-
   __pack_text( "b_part := CREATE_BUFFER( ""{Part}"", GET_INFO( COMMAND_LINE, ""file_name"" ) );" );
   __pack_text( "s_file_spec := GET_INFO( COMMAND_LINE, ""output_file"" );" );
   __pack_text( "SET( OUTPUT_FILE, b_part, s_file_spec );" );
   __pack_text( "b_errors := CREATE_BUFFER( ""{Errors}"" );" );


   !+
   ! Initialize variables.
   !-
   __pack_text( "i_errors := 0;" );
   __pack_text( FAO( "pat_beg_1 := ANCHOR & ""!AS"";", SUBSTR( s_part_begin, 2, 16 ) ) );
   __pack_text( FAO( "pat_beg_2 := LINE_BEGIN & ""!AS"";", SUBSTR( s_part_begin, 1, 17 ) ) );
   __pack_text( FAO( "pat_end := ANCHOR & ""!AS"";", SUBSTR( s_part_end, 2, 13 ) ) );



   !+
   ! Insert code to strip trailing blanks as they will be superfluous
   ! (and wrong!)
   !-
   __pack_text( "POSITION( BEGINNING_OF( b_part ) );" );
   __pack_text( "LOOP" );
   __pack_text( "  EXITIF SEARCH( SPAN( ' ' )@r_trail & LINE_END, FORWARD) = 0;" );
   __pack_text( "  POSITION( r_trail );" );
   __pack_text( "  ERASE( r_trail );" );
   __pack_text( "ENDLOOP;" );



   !+
   ! Set up to scan the buffer and do the following:
   !   o Remove start of line marker characters
   !   o Recombine split lines
   !   o Ignore begin/end part markers and garbage (eg mail headers) in between.
   !-
   __pack_text( "POSITION( BEGINNING_OF( b_part ) );" );
   __pack_text( "i_append_line := 0;" );
   __pack_text( "LOOP" );
   __pack_text( "  EXITIF MARK( NONE ) = END_OF( b_part );" );



   !+
   ! Insert code to remove and examine the start of line marker character
   !-
   __pack_text( "  s_x := ERASE_CHARACTER( 1 );" );


   !+
   ! Insert code to find the start of the part
   !-
   __pack_text( "  IF s_x = '" + SUBSTR( s_part_begin, 1, 1 ) + "' THEN" );
   __pack_text( "    r_skip := SEARCH( pat_beg_1, FORWARD, EXACT );" );
   __pack_text( "    IF r_skip <> 0 THEN" );
   __pack_text( "      s_x := '';" );
   __pack_text( "      MOVE_HORIZONTAL( -CURRENT_OFFSET );" );
   __pack_text( "      ERASE_LINE;" );
   __pack_text( "    ENDIF;" );
   __pack_text( "  ENDIF;" );


   !+
   ! Insert code to deal with the end of a part (ie skip garbage between parts)
   !-
   __pack_text( "  IF s_x = '" + SUBSTR( s_part_end, 1, 1 ) + "' THEN" );
   __pack_text( "    r_skip := SEARCH( pat_end, FORWARD, EXACT );" );
   __pack_text( "    IF r_skip <> 0 THEN" );
   __pack_text( "      s_x := '';" );
   __pack_text( "      MOVE_HORIZONTAL( -CURRENT_OFFSET );" );
   __pack_text( "      m_skip := MARK( NONE );" );
   __pack_text( "      r_skip := SEARCH( pat_beg_2, FORWARD, EXACT );" );
   __pack_text( "      IF r_skip <> 0 THEN" );
   __pack_text( "        POSITION( END_OF( r_skip ) );" );
   __pack_text( "        MOVE_HORIZONTAL( -CURRENT_OFFSET );" );
   __pack_text( "        MOVE_VERTICAL( 1 );" );
   __pack_text( "        MOVE_HORIZONTAL( -1 );" );
   __pack_text( "      ELSE" );
   __pack_text( "        POSITION( END_OF( b_part ) );" );
   __pack_text( "      ENDIF;" );
   __pack_text( "      ERASE( CREATE_RANGE( m_skip, MARK( NONE ), NONE ) );" );
   __pack_text( "    ENDIF;" );
   __pack_text( "  ENDIF;" );


   !+
   ! insert code to deal with a line flagged as continued on next line
   !-
   __pack_text( "  IF s_x = '" + s_long_line + "' THEN" );
   __pack_text( "    s_x := '';" );
   __pack_text( "    IF i_append_line <> 0 THEN" );
   __pack_text( "      APPEND_LINE;" );
   __pack_text( "      MOVE_HORIZONTAL( -CURRENT_OFFSET );" );
   __pack_text( "    ENDIF;" );
   __pack_text( "    i_append_line := 1;" );
   __pack_text( "    MOVE_VERTICAL( 1 );" );
   __pack_text( "  ENDIF;" );


   !+
   ! insert code to deal with a line flagged as non continued (or the last part
   ! of a continued line.
   !-
   __pack_text( "  IF s_x = '" + s_short_line + "' THEN" );
   __pack_text( "    s_x := '';" );
   __pack_text( "    IF i_append_line <> 0 THEN" );
   __pack_text( "      APPEND_LINE;" );
   __pack_text( "      MOVE_HORIZONTAL( -CURRENT_OFFSET );" );
   __pack_text( "    ENDIF;" );
   __pack_text( "    i_append_line := 0;" );
   __pack_text( "    MOVE_VERTICAL( 1 );" );
   __pack_text( "  ENDIF;" );



   !+
   ! insert code to deal with any other line, which must be an error case
   !-
   __pack_text( "  IF s_x <> '' THEN" );
   __pack_text( "    i_errors := i_errors + 1;" );
   __pack_text( "    s_text := CURRENT_LINE;" );
   __pack_text( "    POSITION( b_errors );" );
   __pack_text( "    COPY_TEXT( ""The following line could not be unpacked properly:"" );" );
   __pack_text( "    SPLIT_LINE;" );
   __pack_text( "    COPY_TEXT( s_x );" );
   __pack_text( "    COPY_TEXT( s_text );" );
   __pack_text( "    POSITION( b_part );" );
   __pack_text( "    MOVE_VERTICAL( 1 );" );
   __pack_text( "  ENDIF;" );
   __pack_text( "ENDLOOP;" );


   !+
   ! Insert code to restore escaped characters to their real selves.
   !-
   __pack_text( "POSITION( BEGINNING_OF( b_part ) );" );
   __pack_text( "LOOP" );
   __pack_text( "  r_x := SEARCH( """ + s_quoting_char + """, FORWARD, EXACT );" );
   __pack_text( "  EXITIF r_x = 0;" );
   __pack_text( "  POSITION( r_x );" );
   __pack_text( "  ERASE_CHARACTER( 1 );" );
   __pack_text( "  COPY_TEXT( ASCII( INT( ERASE_CHARACTER( 3 ) ) ) );" );
   __pack_text( "ENDLOOP;" );


   !+
   ! Insert code to summarise all errors encountered.
   !-
   __pack_text( "IF i_errors = 0 THEN" );
   __pack_text( "  SET( NO_WRITE, b_errors, ON );" );
   __pack_text( "ELSE" );
   __pack_text( "  POSITION( BEGINNING_OF( b_errors ) );" );
   __pack_text( "  COPY_TEXT( FAO( ""The following !UL errors were detected while unpacking !AS""," );
   __pack_text( "    i_errors, s_file_spec ) );" );
   __pack_text( "  SPLIT_LINE;" );
   __pack_text( "  SET( OUTPUT_FILE, b_errors, ""SYS$COMMAND"" );" );
   __pack_text( "ENDIF;" );
   __pack_text( "EXIT;" );


   !+
   ! Terminate the packed TPU code properly
   !-
   SPLIT_LINE;


   !+
   ! Add the DCL needed to checksum and tidy up.
   !-
   __copy_text( "$ DELETE VMS_SHARE_DUMMY.DUMMY;*" );
   __copy_text( "$ CHECKSUM 'FILE_IS" );
   __copy_text( "$ WRITE SYS$OUTPUT "" CHECKSUM "", -" );
   __copy_text( "  F$ELEMENT( CHECKSUM_IS .EQ. CHECKSUM$CHECKSUM, "","", ""failed!!,passed."" )" );
   __copy_text( "$ RETURN" );


   !+
   ! End of routine that unpacks a file.
   !-
   __copy_text( "$!" );
   __pack_text( "$START:" );

ENDPROCEDURE;


!+
! Insert an attention mark at the beginning of the packed file if there
! are several parts in the set.
!
! On completion, the previous position is restored.
!-
PROCEDURE WRITE_SHARE_ATTENTION( m_position, ii_max_part_blocks, ii_max_part_bytes )
LOCAL prevposition;

  prevposition := MARK(NONE);
  POSITION( m_position );
  MOVE_VERTICAL( 1 );

  __copy_text( FAO( "$!! ATTENTION: To keep each article below !UL block!%S (!UL byte!%S), this",
    ii_max_part_blocks, ii_max_part_bytes ) );
  __copy_text( FAO( "$!!!12* program has been transmitted in 999 parts.  You should" ) );
  __copy_text( FAO( "$!!!12* concatenate ALL parts to ONE file and execute (@) that file." ) );
  __copy_text( "$!" );

  POSITION( prevposition );

ENDPROCEDURE;





!+----------------------------------------------
!      MAIN CODE STARTS HERE
!+----------------------------------------------

i_max_line := 77;				! Maximum length of output line.
pat_separator := ANY( "&(),:;<" );		! Pattern used to pack TPU commands.
s_blank := " ";					! ASCII blank character.
s_facility_name := "VMS_SHARE";			! Facility name.
s_facility_version := "V06.10 7-FEB-1989";	! Facility version number.
s_long_line := "V";				! Long line prefix character.
s_quote := '"';					! An ASCII quote character.
s_quoting_char := "`";				! 'Escape' character.
s_short_line := "X";				! Short line prefix character.
!+
! NOTE: The format of the following four strings is such that this routine
!       will always work for up to 999 parts.
!-
s_part_begin := "+-+-+-+ Beginning of part !UL +-+-+-+";
s_part_end   := "-+-+-+-+-+ End of part !UL +-+-+-+-+-";
s_part_goto  := "$ GOTO PART!UL";
s_part_label := "$PART!UL:";

INIT_ASCII;



!+
! Read in the file containing the names of the files and their checksums.
! Extract the username, the maximum part size, the count of files to be
! processed and the name of the output (SHARE) file.
!-
b_dummy := CREATE_BUFFER( "{Share}", GET_INFO( COMMAND_LINE, "FILE_NAME" ) );
SET( NO_WRITE, b_dummy, ON );
POSITION( BEGINNING_OF ( b_dummy ) );

s_user := __get_quoted_string;			! USERNAME of creator.

i_max_part_blocks := INT( __get_quoted_string );
i_max_part_bytes := i_max_part_blocks * 512;	! Maximum bytes in each part.

i_num_files := INT( __get_quoted_string );	! Number of file to process.

s_share_file := __get_quoted_string;		! Name of the output (SHARE) file.
s_output_file := s_share_file;			! Internal name of the output (SHARE) file.
IF FILE_PARSE( s_output_file, "", "", TYPE ) <> "."
THEN
  s_output_file := s_output_file + "_";
ENDIF;



!+
!  Create and initialize a buffer to hold the created SHARE file
!-
b_packed := CREATE_BUFFER( "{Packed}" );
WRITE_SHARE_PROLOG( b_packed );
WRITE_SHARE_UNPACK( b_packed );


!+
! Loop through the files appending each file to the common share file.
!-
i_file_num := 0;
LOOP
  i_file_num := i_file_num + 1;
  EXITIF i_file_num > i_num_files;

  POSITION( BEGINNING_OF( b_dummy ) );
  MOVE_VERTICAL( i_file_num );
  s_file_spec := __get_quoted_string;
  s_checksum := __get_quoted_string;
  s_file_name := FILE_PARSE( s_file_spec, "", "", NAME ) + FILE_PARSE( s_file_spec, "", "", TYPE );

  POSITION( m_note_filename );
  MOVE_VERTICAL( i_file_num );
  __copy_text( "$!        " + s_file_name );

  b_file := CREATE_BUFFER( s_file_spec, s_file_spec );
  SET( NO_WRITE, b_file, ON );
  QUOTE_BUFFER( b_file, s_quoting_char );	! Escape the escape character
  QUOTE_BUFFER( b_file, pat_control );		! Escape control chars
  QUOTE_BUFFER( b_file, " "&LINE_END );		! Escape trailing blanks
  WRAP_AND_PREFIX_LINES( b_file);		! Do line wrapping etc.

  POSITION( END_OF( b_packed ) );
  __copy_text( "$ FILE_IS = """ + s_file_name + """" );
  __copy_text( "$ CHECKSUM_IS = " +  s_checksum );
  __copy_text( "$ COPY SYS$INPUT VMS_SHARE_DUMMY.DUMMY" );
  COPY_TEXT( b_file );
  DELETE( b_file );

  __copy_text( "$ GOSUB UNPACK_FILE" );

ENDLOOP;
COPY_TEXT( "$ EXIT" );


!+
! Compute the size of the packed buffer.
!-
i_length := 0;
POSITION( BEGINNING_OF( b_packed ) );
LOOP
  EXITIF MARK( NONE ) = END_OF( b_packed );
  i_line_length := LENGTH( CURRENT_LINE ) + 2;
  IF ( i_line_length - ( ( i_line_length / 2 ) * 2 ) ) <> 0
  THEN
    i_line_length := i_line_length + 1;
  ENDIF;
  i_length := i_length + i_line_length;
  MOVE_VERTICAL( 1 );
ENDLOOP;


!+
! Handle differently if only one part or more than one part will be written.
!-
IF i_length < i_max_part_bytes
THEN

  !+
  ! Set the number of parts and the name of the output file.
  !-
  i_parts := 1;
  SET( OUTPUT_FILE, b_packed, FAO( "!AS1_OF_1", s_output_file ) );

ELSE

  !+
  ! Since more than one part will be written, insert the ATTENTION message.
  !-
  !+
  WRITE_SHARE_ATTENTION( m_attention_text, i_max_part_blocks, i_max_part_bytes );


  ! Skip the first part for now since the number of parts will have to be corrected later.
  !-
  POSITION( BEGINNING_OF( b_packed ) );
  __find_part_end;
  MOVE_HORIZONTAL( -(CURRENT_OFFSET + 1) );


  !+
  ! Determine if a GOTO/label pair is needed for Part 1/Part 2 boundary.
  !-
  MOVE_VERTICAL( -1 );
  s_x := CURRENT_CHARACTER;
  MOVE_VERTICAL( 1 );
  IF s_x = "$"
  THEN
    i_label_needed := 1;
  ELSE
    i_label_needed := 0;
  ENDIF;


  !+
  ! Initialize the number of parts and the starting part number.
  !-
  i_part_num := 2;
  i_parts := 1;


  !+
  ! Loop through the rest of the parts moving the text to part buffers.
  !-
  LOOP

    !+
    ! Move the next part into the part buffer.
    !-
    POSITION( b_packed );
    EXITIF MARK( NONE ) = END_OF( b_packed );

    MOVE_HORIZONTAL( -(CURRENT_OFFSET) );
    m_part_begin := MARK( NONE );
    __find_part_end;
    MOVE_HORIZONTAL( -(CURRENT_OFFSET + 1) );
    r_part := CREATE_RANGE( m_part_begin, MARK( NONE ), NONE );
    b_part := CREATE_BUFFER( FAO( "{Part !UL}", i_part_num ) );
    POSITION( b_part );
    COPY_TEXT( FAO( s_part_begin, i_part_num ) );
    IF i_label_needed <> 0
    THEN
      SPLIT_LINE;
      COPY_TEXT( FAO( s_part_label, i_part_num ) );
    ENDIF;
    POSITION( END_OF( b_part ) );
    MOVE_TEXT( r_part );
    POSITION( END_OF( b_part ) );


    !+
    ! Determine if a GOTO/label pair is needed for Part n/Part n+1 boundary.
    !-
    MOVE_VERTICAL( -1 );
    s_x := CURRENT_CHARACTER;
    MOVE_VERTICAL( 1 );
    IF ( s_x = "$" ) AND ( END_OF( r_part ) <> END_OF( b_packed ) )
    THEN
      __copy_text( FAO( s_part_goto, i_part_num + 1 ) );
      i_label_needed := 1;
    ELSE
      i_label_needed := 0;
    ENDIF;
    COPY_TEXT( FAO( s_part_end, i_part_num ) );


    i_part_num := i_part_num + 1;	! next part
    i_parts := i_parts + 1;

  ENDLOOP;


  !+
  ! Now that the number of parts is known, update the number of parts in part 1 and move it to it's part buffer.
  !-
  POSITION( m_attention_text );
  r_parts := SEARCH( "999", FORWARD );
  ERASE( r_parts );
  POSITION( END_OF( r_parts ) );
  COPY_TEXT( STR( i_parts ) );

  b_part := CREATE_BUFFER( "{Part 1}" );
  POSITION( b_part );
  MOVE_TEXT( b_packed );
  POSITION( END_OF( b_part ) );
  MOVE_VERTICAL( -1 );
  s_x := CURRENT_CHARACTER;
  MOVE_VERTICAL( 1 );

  !+
  ! Only insert a "$GOTO PART2"  if this part ends in some DCL code
  !-
  IF s_x = "$" THEN  __copy_text( FAO( s_part_goto, 2 ) );  ENDIF;
  COPY_TEXT( FAO( s_part_end, 1 ) );
  DELETE( b_packed );


  !+
  ! Loop through all of the parts setting the file name to be associated with that part.
  !-

  i_digits := LENGTH( STR( i_parts) );	! Determine part size for neat format
  i_part_num := 1;			! Initialize part number

  LOOP

    EXITIF i_part_num > i_parts;	! exit if done all parts

    !+
    !  Find next buffer and set it's output filename.
    !-
    b_part := __find_buffer( FAO( "{Part !UL}", i_part_num ) );
    SET( OUTPUT_FILE, b_part, FAO( "!AS!#ZL_OF_!UL", s_output_file, i_digits, i_part_num, i_parts ) );

    i_part_num := i_part_num + 1;	! Next part

  ENDLOOP;

ENDIF;

!+
! Create final output message buffer and fill it.
!-
b_message := CREATE_BUFFER( "{Message}" );
POSITION( b_message );
__copy_text( FAO( "SHARE-file !AS was written in !UL part!%S as follows:", s_share_file, i_parts ) );
SET( NO_WRITE, b_message, OFF );
SET( OUTPUT_FILE, b_message, "SYS$COMMAND" );

EXIT;
$ DELETE/NOLOG/NOCONFIRM VMS_SHARE_DUMMY.DUMMY;*
$ DIRECTORY/DATE=CREATED/NOHEADER/SIZE=USED/VERSIONS=1/WIDTH=(FILENAME=47,SIZE=4) 'SHARE_FILE'*_OF_*
$ VERIFY = F$VERIFY( VERIFY )