home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 18 REXX
/
18-REXX.zip
/
rexxuuxx.zip
/
UUXXCODE.PLI
< prev
next >
Wrap
Text File
|
1997-05-13
|
41KB
|
875 lines
%PROCESS DLLINIT;
/*********************************************************************/
/* This program is freeware, distributed as is, without any warranty */
/* of its usefulness for any purpose. You may use it freely. You may */
/* also redistribute it, provided no charge is levied beyond the */
/* price of its distribution medium. However, the author retains all */
/* intellectual property rights. */
/* */
/* */
/* Copyright (C) David W. Noon, 1995, 1997 */
/* */
/*********************************************************************/
/* Dynamic link Library to encode and decode messages */
/* using UU, XX or BASE64 coding. */
/* */
/* Author: David W. Noon */
/* January 1995 */
(NOOFL,NOUFL,NOFOFL,NOZDIV):
UUXXCODE:
PACKAGE OPTIONS(REENTRANT REORDER)
EXPORTS(UUDECODE_FILE,UUENCODE_FILE,XXDECODE_FILE,
XXENCODE_FILE,BASE64_DECODE,BASE64_ENCODE);
/* Global constants */
DCL UU_default_xlate_table CHAR(64) VALUE(
'`!"#$%&''()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_'),
XX_default_xlate_table CHAR(64) VALUE(
'+-0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz'),
Base64_xlate_table CHAR(64) VALUE(
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/');
UUDECODE_FILE:
PROC(Parm_ptr) OPTIONS(BYVALUE NODESCRIPTOR);
DCL Parm_ptr PTR;
DCL 1 Parm_struct BASED(Parm_ptr) NONASGN,
2 In_len BIN FIXED(16,0) UNSIGNED,
2 Horton_bug BIT(1) ALIGNED,
2 Msg_file CHAR(260) VAR,
2 Input_filename CHAR((260) REFER (In_len)) VAR;
CALL UUXXDECODE_FILE(Input_filename,UU_default_xlate_table,
Horton_bug,Msg_file);
RETURN;
END UUDECODE_FILE;
XXDECODE_FILE:
PROC(Parm_ptr) OPTIONS(BYVALUE NODESCRIPTOR);
DCL Parm_ptr PTR;
DCL 1 Parm_struct BASED(Parm_ptr) NONASGN,
2 In_len BIN FIXED(16,0) UNSIGNED,
2 Horton_bug BIT(1) ALIGNED,
2 Msg_file CHAR(260) VAR,
2 Input_filename CHAR((260) REFER (In_len)) VAR;
CALL UUXXDECODE_FILE(Input_filename,XX_default_xlate_table,
Horton_bug,Msg_file);
RETURN;
END XXDECODE_FILE;
UUENCODE_FILE:
PROC(Parm_ptr) OPTIONS(BYVALUE NODESCRIPTOR);
DCL Parm_ptr PTR;
DCL 1 Parm_struct BASED(Parm_ptr) NONASGN,
2 In_cnt BIN FIXED(16,0) UNSIGNED,
2 Output_filename CHAR(260) VAR,
2 Msg_file CHAR(260) VAR,
2 Input_filename((1) REFER (In_cnt)) CHAR(260) VAR;
CALL UUXXENCODE_FILE(Input_filename,Output_filename,
UU_default_xlate_table);
RETURN;
END UUENCODE_FILE;
XXENCODE_FILE:
PROC(Parm_ptr) OPTIONS(BYVALUE NODESCRIPTOR);
DCL Parm_ptr PTR;
DCL 1 Parm_struct BASED(Parm_ptr) NONASGN,
2 In_cnt BIN FIXED(16,0) UNSIGNED,
2 Output_filename CHAR(260) VAR,
2 Msg_file CHAR(260) VAR,
2 Input_filename((1) REFER (In_cnt)) CHAR(260) VAR;
CALL UUXXENCODE_FILE(Input_filename,Output_filename,
XX_default_xlate_table);
RETURN;
END XXENCODE_FILE;
%PAGE;
/****************************************************/
/* */
/* Subroutine to decode UUENCODEd or XXENCODEd */
/* messages, as per Unix. */
/* */
/****************************************************/
UUXXDECODE_FILE:
PROC(Input_filename_list,Default_xlate_table,Horton_bug,Msg_file);
DCL Input_filename_list CHAR(*) NONASGN,
Default_xlate_table CHAR(64) NONASGN,
Horton_bug BIT(1) ALIGNED NONASGN,
Msg_file CHAR(*) VAR NONASGN;
DCL (Bytes_written,Check_sum,Byte_count,File_count,i,p,Scan_cnt)
BIN FIXED(31,0) UNSIGNED,
Slack_bytes BIN FIXED(31,0) SIGNED,
Biased_byte BIN FIXED(8,0) UNSIGNED,
Filename_array(*) CHAR(*) VAR CTL,
Output_filename CHAR(256) VAR INIT(''),
Table_area CHAR(65)
INIT((Default_xlate_table||' ')),
Xlate_table CHAR(64) DEF Table_area POS(1),
Unbiased_ptr PTR,
1 Unbiased_bits UNION BASED(Unbiased_ptr),
2 Unbiased_bytes CHAR(4),
2 Byte_value(4) BIN FIXED(8,0) UNSIGNED,
2 Bit_fields,
3 * BIT(2),
3 Unbiased_bits_1 BIT(6),
3 * BIT(2),
3 Unbiased_bits_1A BIT(2),
3 Unbiased_bits_2 BIT(4),
3 * BIT(2),
3 Unbiased_bits_2A BIT(4),
3 Unbiased_bits_3 BIT(2),
3 * BIT(2),
3 Unbiased_bits_3A BIT(6),
(Suppress_checksums,Trailing_blanks_added,Prefix_read) BIT(1),
Input_record CHAR(512) VAR,
Output_rec_ptr PTR,
1 Output_rec_area BASED(Output_rec_ptr),
2 Output_rec_len BIN FIXED(31,0) UNSIGNED,
2 Output_rec((Byte_count) REFER (Output_rec_len))
BIN FIXED(8,0) UNSIGNED,
(ADDR,COLLATE,COPY,DIVIDE,FILEWRITE,HBOUND,IAND,ISLL,ISRL,LBOUND,
LEFT,LENGTH,MOD,RANK,REM,RIGHT,SEARCH,SUBSTR,TRANSLATE,
TRIM,UNSPEC,VERIFY) BUILTIN,
Input_file FILE RECORD INPUT INT
ENV(CONSECUTIVE),
Output_file FILE RECORD OUTPUT INT
ENV(CONSECUTIVE RECSIZE(1)),
SYSPRINT PRINT INT;
OPEN FILE(SYSPRINT) PAGESIZE(55) TITLE('/'||Msg_file);
CALL Split_concatenated_files(Input_filename_list,Filename_array);
/* We haven't read a UU/XX prefix yet. */
Prefix_read = '0'B;
PUT FILE(SYSPRINT) EDIT
('Records dropped from file(s) ',Input_filename_list,':')
(A);
/* We come back here after each encoded file in the
input stream has been decoded. */
DO File_count = LBOUND(Filename_array,1) TO HBOUND(Filename_array,1);
/* Ignore any file that cannot be found */
ON UNDF(Input_file)
BEGIN;
PUT FILE(SYSPRINT) EDIT
('Unable to open file ',Filename_array(File_count))
(A);
GO TO Skip_file;
END;
OPEN FILE(Input_file) TITLE('/'||Filename_array(File_count)||
',TYPE(TEXT),RECSIZE(512)');
ON ENDFILE(Input_file)
GO TO End_of_input;
/* We come back here after we have completely decoded an output
output file. We keep reading the input file, in case it
contains more than one output file. */
Read_input_file:
DO LOOP;
IF ¬ Prefix_read THEN
DO;
/* Look for the 'begin 666 filename.xxx' prefix */
DO UNTIL(Prefix_read);
READ FILE(Input_file) INTO(Input_record);
/* Get rid of trailing blanks */
Input_record = TRIM(Input_record,'',' ');
SELECT;
WHEN(Input_record = 'table')
DO;
/* We have a custom tramslation table! */
READ FILE(Input_file) INTO(Input_record);
SUBSTR(Xlate_table,1,32) = Input_record;
READ FILE(Input_file) INTO(Input_record);
SUBSTR(Xlate_table,33,32) = Input_record;
END;
WHEN(LENGTH(Input_record) > 7 &
LEFT(Input_record,6) = 'begin ')
DO;
/* Bingo! We have a begin */
p = VERIFY(Input_record,' ',7);
IF p ¬= 0 THEN
DO;
/* Skip over mode */
p = SEARCH(Input_record,' ',p);
IF p ¬= 0 THEN
DO;
/* Find filename */
p = VERIFY(Input_record,' ',p);
IF p ¬= 0 THEN
DO;
Output_filename =
SUBSTR(Input_record,p);
Prefix_read = '1'B;
END;
END;
END;
END;
OTHERWISE
PUT FILE(SYSPRINT) SKIP EDIT
(Input_record)
(A);
END;
END;
/* Initialise counter */
Bytes_written = 0;
/* Allow checksums, by default */
Suppress_checksums = '0'B;
PUT FILE(SYSPRINT) EDIT
('Decoding file ',Output_filename,' using table:',
Xlate_table)
(SKIP,3 A);
/* Open the output file in the current directory */
OPEN FILE(Output_file) TITLE('/'||Output_filename||
',TYPE(U),EA(N),APPEND(N)');
END;
Decode_loop:
DO LOOP;
DO UNTIL(LENGTH(Input_record) ¬= 0 &
LEFT(Input_record,1) ¬= LEFT(Xlate_table,1));
READ FILE(Input_file) INTO(Input_record);
/* Get rid of trailing blanks */
Input_record = TRIM(Input_record,'',' ');
IF Input_record = 'end' THEN
LEAVE Decode_loop;
END;
Byte_count = SEARCH(Xlate_table,LEFT(Input_record,1));
IF Byte_count > 1 &
VERIFY(Input_record,Table_area,2) = 0 THEN
Process_record:
DO;
Byte_count -= 1;
Scan_cnt = DIVIDE(Byte_count*4+2,3,16,0);
Slack_bytes = LENGTH(Input_record) - Scan_cnt;
SELECT;
WHEN(Slack_bytes < 1)
DO; /* Pad record with trailing "blanks". */
IF Suppress_checksums THEN
DO;
p = 1 - Slack_bytes;
Slack_bytes = 1;
END;
ELSE
DO;
p = 2 - Slack_bytes;
Slack_bytes = 2;
END;
Input_record ||= COPY(LEFT(Xlate_table,1),p);
Trailing_blanks_added = '1'B;
END;
WHEN(Slack_bytes > 2 + MOD(-Scan_cnt,4))
DO; /* Record is too long */
PUT FILE(SYSPRINT) SKIP EDIT
(Input_record,'Slack_bytes = ',Slack_bytes)
(A,SKIP,A,F(5));
LEAVE Process_record; /* Drop the record */
END;
OTHERWISE
Trailing_blanks_added = '0'B;
END;
/* Take care of blanks as lowest value bytes */
IF LEFT(Xlate_table,1) ¬= ' ' THEN
Input_record = TRANSLATE(Input_record,
LEFT(Xlate_table,1),' ');
IF ¬ Suppress_checksums & ¬ Horton_bug THEN
IF Slack_bytes = 2 THEN
DO;
Check_sum = 0;
DO i = 2 TO LENGTH(Input_record) - 1;
Check_sum +=
RANK(SUBSTR(Input_record,i,1));
END;
Biased_byte = SEARCH(Xlate_table,
RIGHT(Input_record,1)) - 1;
IF REM(Check_sum,64) ¬= Biased_byte &
RIGHT(Input_record,1) ¬= 'M' &
RIGHT(Input_record,1) ¬= LEFT(Xlate_table,1)
THEN
DO;
IF Trailing_blanks_added THEN
Suppress_checksums = '1'B;
ELSE
PUT FILE(SYSPRINT) SKIP EDIT
(Input_record,'Calc. checksum =',
Check_sum,
'Checksum byte =',Biased_byte)
(A,SKIP,2(A,F(6)));
END;
END;
ELSE
Suppress_checksums = '1'B;
/* Allocate an output work area of sufficient length */
ALLOCATE Output_rec_area SET(Output_rec_ptr);
Output_rec_len = 0;
/* Remove the bias on all the bytes */
SUBSTR(Input_record,2) =
TRANSLATE(SUBSTR(Input_record,2),
LEFT(COLLATE,LENGTH(Xlate_table)),
Xlate_table);
/* Decode 4-byte chunks into 3-byte chunks */
DO Unbiased_ptr = ADDR(Input_record) + 3 BY 4
TO ADDR(Input_record) + (Scan_cnt - 1);
Output_rec(Output_rec_len+1) =
ISLL(Byte_value(1),2) +
ISRL(Byte_value(2),4);
Output_rec(Output_rec_len+2) =
ISLL(Byte_value(2),4) +
ISRL(Byte_value(3),2);
Output_rec(Output_rec_len+3) =
ISLL(Byte_value(3),6) +
Byte_value(4);
Output_rec_len += 3;
END;
/* See if we have any stragglers left */
i = REM(Byte_count,3);
IF i ¬= 0 THEN
DO; /* Unbiased_ptr should already point there */
Output_rec(Output_rec_len+1) =
ISLL(Byte_value(1),2) +
ISRL(Byte_value(2),4);
Output_rec_len += i;
IF i = 2 THEN
Output_rec(Output_rec_len) =
ISLL(Byte_value(2),4) +
ISRL(Byte_value(3),2);
END;
IF Output_rec_len ¬= Byte_count THEN
DO;
PUT FILE(SYSPRINT) SKIP EDIT
(Input_record,'Byte_count =',Byte_count,
'Output_rec_len =',Output_rec_len)
(A,SKIP,2(A,F(4)));
Output_rec_len = Byte_count;
FREE Output_rec_area;
LEAVE Process_record; /* Drop the record */
END;
/* See if we need to correct Horton's error */
IF ¬ Suppress_checksums & Horton_bug THEN
IF Slack_bytes = 2 THEN
DO;
Check_sum = 0;
DO i = 1 TO Output_rec_len;
Check_sum += Output_rec(i);
END;
p = Scan_cnt + 2;
/* Determine how many bytes of "float" */
SELECT(LENGTH(Input_record) - p);
WHEN(1)
DO; /* 1 byte "float" */
Check_sum +=
RANK(SUBSTR(Input_record,p,1));
END;
WHEN(2)
DO; /* 2 byte "float" */
Unbiased_ptr = ADDR(Input_record) +
(p + 1);
Check_sum +=
ISLL(Byte_value(1),2) +
ISRL(Byte_value(2),4);
END;
WHEN(3)
DO; /* 3 byte "float" */
Unbiased_ptr = ADDR(Input_record) +
(p + 1);
Check_sum +=
ISLL(Byte_value(1),2) +
ISRL(Byte_value(2),4) +
ISLL(Byte_value(2),4) +
ISRL(Byte_value(3),2);
END;
OTHERWISE
/* Let it die */;
END;
Biased_byte = SEARCH(Xlate_table,
RIGHT(Input_record,1)) - 1;
IF REM(Check_sum,64) ¬= Biased_byte THEN
DO;
IF Trailing_blanks_added THEN
Suppress_checksums = '1'B;
ELSE
PUT FILE(SYSPRINT) SKIP EDIT
(Input_record,'Calc. checksum =',
Check_sum,
'Checksum byte =',Biased_byte)
(A,SKIP,2(A,F(6)));
END;
END;
ELSE
Suppress_checksums = '1'B;
/* Write this run of bytes to the decoded file */
Bytes_written += FILEWRITE(Output_file,
ADDR(Output_rec),Output_rec_len);
/* No memory leaks here */
FREE Output_rec_area;
END;
ELSE
PUT FILE(SYSPRINT) SKIP EDIT
(Input_record)
(A);
END Decode_loop;
PUT FILE(SYSPRINT) SKIP(2) EDIT
('File ',Output_filename,' successfully decoded. Bytes written:',
Bytes_written)
(3 A,F(9));
CLOSE FILE(Output_file);
/* We need another UU/XX prefix now. */
Prefix_read = '0'B;
END Read_input_file;
/* This one's done. Try the next input file. */
End_of_input:
CLOSE FILE(Input_file);
Skip_file:
END;
IF Prefix_read THEN
DO; /* We never hit the 'end' record after a 'begin' was found */
PUT FILE(SYSPRINT) SKIP(2) EDIT
("'end' record not found! Encoded file is probably corrupt.")
(A)
('File ',Output_filename,' NOT successfully decoded. Bytes written:',
Bytes_written)
(SKIP,3 A,F(9));
CLOSE FILE(Output_file);
END;
CLOSE FILE(SYSPRINT);
/* Again, no memory leaks */
FREE Filename_array;
RETURN;
END UUXXDECODE_FILE;
%PAGE;
/****************************************************/
/* */
/* Subroutine to encode UUENCODEd or XXENCODEd */
/* messages, as per Unix. */
/* */
/****************************************************/
UUXXENCODE_FILE:
PROC(Input_filename,Output_filename,Xlate_table);
DCL Input_filename(*) CHAR(*) VAR NONASGN,
Output_filename CHAR(*) VAR NONASGN,
Xlate_table CHAR(64) NONASGN;
DCL (Byte_count,Check_sum,Rec_len,p) BIN FIXED(31,0) UNSIGNED,
j BIN FIXED(31,0) SIGNED,
Output_byte BIN FIXED(8,0) UNSIGNED,
Table_record CHAR(5) STATIC NONASGN
INIT('table'),
End_record CHAR(3) STATIC NONASGN
INIT('end'),
Output_record CHAR(62) VAR,
Decoded_bytes BIT(45*8) ALIGNED,
(ADDR,COPY,EDIT,FILEREAD,HBOUND,ISLL,LBOUND,LEFT,LENGTH,PLIFILL,
RANK,REM,SEARCHR,STG,SUBSTR,TRIM,UNSPEC) BUILTIN,
Input_file FILE RECORD INPUT INT
ENV(CONSECUTIVE RECSIZE(1)),
Output_file FILE RECORD OUTPUT INT
ENV(CONSECUTIVE RECSIZE(64));
OPEN FILE(Output_file) TITLE('/'||Output_filename||
',TYPE(TEXT),EA(N),APPEND(N)');
/* Write the current translation table as a custom table */
WRITE FILE(Output_file) FROM(Table_record);
Output_record = LEFT(Xlate_table,32);
WRITE FILE(Output_file) FROM(Output_record);
Output_record = SUBSTR(Xlate_table,33,32);
WRITE FILE(Output_file) FROM(Output_record);
/* Loop through all files requested */
DO j = LBOUND(Input_filename) TO HBOUND(Input_filename);
/* Ignore any file that cannot be found */
ON UNDF(Input_file)
GO TO Skip_file;
OPEN FILE(Input_file) TITLE('/'||Input_filename(j)||',TYPE(U)');
/* Write an empty line, then a 'begin' prefix record */
Output_record = '';
WRITE FILE(Output_file) FROM(Output_record);
/* Scrap any drive/path info. in filename */
p = SEARCHR(Input_filename(j),'/:\');
Output_record = 'begin 666 ' || SUBSTR(Input_filename(j),p+1);
WRITE FILE(Output_file) FROM(Output_record);
Byte_count = 0;
DO LOOP;
/* Make the output work area all low values */
CALL PLIFILL(ADDR(Decoded_bytes),'00'X,STG(Decoded_bytes));
/* Read an input work area */
Rec_len = FILEREAD(Input_file,ADDR(Decoded_bytes),
STG(Decoded_bytes));
Byte_count += Rec_len;
/* A short record means that's all that's left */
IF Rec_len < STG(Decoded_bytes) THEN
LEAVE;
/* Encode the data into the output work area
First, the default length */
Output_record = SUBSTR(Xlate_table,46,1);
/* Now encode each group of 6 bits as a byte */
DO p = 1 TO LENGTH(Decoded_bytes) - 5 BY 6;
UNSPEC(Output_byte) = '00'B || SUBSTR(Decoded_bytes,p,6);
Output_record ||= SUBSTR(Xlate_table,Output_byte+1,1);
END;
/* Calculate the checksum */
Check_sum = 0;
DO p = 2 UPTHRU 61;
Check_sum += RANK(SUBSTR(Output_record,p,1));
END;
/* Append the checksum. for those who care */
Output_record ||= SUBSTR(Xlate_table,REM(Check_sum,64)+1,1);
/* Write the output work area to the output file */
WRITE FILE(Output_file) FROM(Output_record);
END;
CLOSE FILE(Input_file);
/* In case the last record had some bytes in it ... */
IF Rec_len > 0 THEN
DO;
/* Encode the data into the output work area
First, the default length */
Output_record = SUBSTR(Xlate_table,Rec_len+1,1);
/* Now encode each group of 6 bits as a byte */
DO p = 1 TO ISLL(Rec_len,3) BY 6;
UNSPEC(Output_byte) = '00'B || SUBSTR(Decoded_bytes,p,6);
Output_record ||= SUBSTR(Xlate_table,Output_byte+1,1);
END;
/* Calculate the checksum */
Check_sum = 0;
DO p = 2 UPTHRU LENGTH(Output_record);
Check_sum += RANK(SUBSTR(Output_record,p,1));
END;
/* Append the checksum. for those who care */
Output_record ||= SUBSTR(Xlate_table,REM(Check_sum,64)+1,1);
/* Write the output work area to the output file */
WRITE FILE(Output_file) FROM(Output_record);
END;
/* Write a zero-length encoded record */
Output_record = COPY(LEFT(Xlate_table,1),2);
WRITE FILE(Output_file) FROM(Output_record);
/* Now an 'end' record */
WRITE FILE(Output_file) FROM(End_record);
/* Now write the size the decoder should expect */
Output_record = 'size ' || TRIM(EDIT(Byte_count,'(8)Z9'));
WRITE FILE(Output_file) FROM(Output_record);
Skip_file:
END;
CLOSE FILE(Output_file);
RETURN;
END UUXXENCODE_FILE;
%PAGE;
/****************************************************/
/* */
/* Subroutine to decode BASE64 messages as per Unix */
/* */
/****************************************************/
BASE64_DECODE:
PROC(Parm_ptr) OPTIONS(BYVALUE NODESCRIPTOR);
DCL Parm_ptr PTR;
DCL 1 Parm_struct BASED(Parm_ptr) NONASGN,
2 Valid_rec_len BIN FIXED(16,0) UNSIGNED,
2 In_len BIN FIXED(16,0) UNSIGNED,
2 Output_filename CHAR(260) VAR,
2 Msg_file CHAR(260) VAR,
2 Input_filename_list CHAR((260) REFER (In_len)) VAR;
DCL (File_count,j,Trail) BIN FIXED(31,0) UNSIGNED,
Bytes_written BIN FIXED(31,0) UNSIGNED
INIT(0),
Filename_array(*) CHAR(*) VAR CTL,
Input_record CHAR(Valid_rec_len) VAR,
Encoded_ptr PTR,
1 Encoded_bits UNION BASED(Encoded_ptr),
2 Encoded_bytes CHAR(4),
2 Byte_value(4) BIN FIXED(8,0) UNSIGNED,
2 Bit_fields,
3 * BIT(2),
3 Bit_field_1 BIT(6),
3 * BIT(2),
3 Bit_field_1A BIT(2),
3 Bit_field_2 BIT(4),
3 * BIT(2),
3 Bit_field_2A BIT(4),
3 Bit_field_3 BIT(2),
3 * BIT(2),
3 Bit_field_3A BIT(6),
Decoded_byte(0:(Valid_rec_len*3)/4-1) BIN FIXED(8,0) UNSIGNED,
Equal_sign_found BIT(1) INIT('0'B),
Recsize_text CHAR(26),
(ADDR,COLLATE,FILEWRITE,HBOUND,IAND,ISLL,ISRL,LBOUND,LEFT,
LENGTH,REM,RIGHT,TRANSLATE,TRIM,VERIFY) BUILTIN,
Input_file FILE RECORD INPUT INT
ENV(CONSECUTIVE),
Output_file FILE RECORD OUTPUT INT
ENV(CONSECUTIVE RECSIZE(1)),
SYSPRINT PRINT INT;
OPEN FILE(SYSPRINT) PAGESIZE(55) TITLE('/'||Msg_file),
FILE(Output_file) TITLE('/'||Output_filename||
',TYPE(U),EA(N),APPEND(N)');
/* Format the record size for later use */
PUT STRING(Recsize_text) EDIT
(',TYPE(TEXT),RECSIZE(',Valid_rec_len,')')
(A,P'(5)9',A);
CALL Split_concatenated_files(Input_filename_list,Filename_array);
PUT FILE(SYSPRINT) EDIT
('Records dropped from file(s) ',Input_filename_list,':')
(A);
DO File_count = LBOUND(Filename_array,1) TO HBOUND(Filename_array,1)
UNTIL(Equal_sign_found);
/* Ignore any file that cannot be found */
ON UNDF(Input_file)
BEGIN;
PUT FILE(SYSPRINT) EDIT
('Unable to open file ',Filename_array(File_count))
(A);
GO TO Skip_file;
END;
OPEN FILE(Input_file) TITLE('/'||Filename_array(File_count)||
Recsize_text);
ON ENDFILE(Input_file)
GO TO End_of_file;
/* Ignore any over-length records */
ON RECORD(Input_file)
Input_record = '';
DO UNTIL(Equal_sign_found);
DO UNTIL(LENGTH(Input_record) > 0);
READ FILE(Input_file) INTO(Input_record);
END;
IF RIGHT(Input_record,1) = '=' THEN
DO;
Input_record = TRIM(Input_record,'','=');
Equal_sign_found =
VERIFY(Input_record,Base64_xlate_table) = 0;
END;
/* Determine no. of trailing bytes. Should be 0, 2 or 3 */
Trail = REM(LENGTH(Input_record),4);
IF Equal_sign_found | (Trail ¬= 1 &
VERIFY(Input_record,Base64_xlate_table) = 0) THEN
DO;
Input_record = TRANSLATE(Input_record,LEFT(COLLATE,64),
Base64_xlate_table);
j = 0;
/* Translate each chunk of 4 bytes into 3 decoded bytes */
DO Encoded_ptr = ADDR(Input_record) + 2 BY 4
TO ADDR(Input_record) +
(LENGTH(Input_record) - Trail - 2);
Decoded_byte(j) = ISLL(Byte_value(1),2) +
ISRL(Byte_value(2),4);
Decoded_byte(j+1) = ISLL(Byte_value(2),4) +
ISRL(Byte_value(3),2);
Decoded_byte(j+2) = ISLL(Byte_value(3),6) +
Byte_value(4);
j += 3;
END;
/* Now take care of any trailing bytes */
IF Trail > 0 THEN
DO;
Decoded_byte(j) = ISLL(Byte_value(1),2) +
ISRL(Byte_value(2),4);
j += 1;
IF Trail = 3 THEN
DO;
Decoded_byte(j) = ISLL(Byte_value(2),4) +
ISRL(Byte_value(3),2);
j += 1;
END;
END;
/* Write the decoded bytes to the output file */
Bytes_written +=
FILEWRITE(Output_file,ADDR(Decoded_byte),j);
END;
ELSE
PUT FILE(SYSPRINT) EDIT
(Input_record)
(SKIP,A);
END; /* DO UNTIL(Equal_sign_found) */
End_of_file:
CLOSE FILE(Input_file);
Skip_file:
END; /* DO File_count = */
IF Equal_sign_found THEN
PUT FILE(SYSPRINT) EDIT
('File ',Output_filename,' successfully decoded. Bytes written:',
Bytes_written)
(SKIP,3 A,F(9));
ELSE
PUT FILE(SYSPRINT) EDIT
('Trailing equal sign not found! Encoded file is probably corrupt.')
(SKIP,A)
('File ',Output_filename,' NOT successfully decoded. Bytes written:',
Bytes_written)
(SKIP,3 A,F(9));
CLOSE FILE(Output_file),
FILE(SYSPRINT);
FREE Filename_array;
RETURN;
END BASE64_DECODE;
%PAGE;
/****************************************************/
/* */
/* Subroutine to encode BASE64 messages as per Unix */
/* */
/****************************************************/
BASE64_ENCODE:
PROC(Parm_ptr) OPTIONS(BYVALUE NODESCRIPTOR);
DCL Parm_ptr PTR;
DCL 1 Parm_struct BASED(Parm_ptr) NONASGN,
2 Input_filename CHAR(260) VAR,
2 Output_filename CHAR(260) VAR;
DCL (Rec_len,p) BIN FIXED(31,0) UNSIGNED,
Output_byte BIN FIXED(8,0) UNSIGNED,
Output_record CHAR(60) VAR,
Decoded_bytes BIT(45*8) ALIGNED,
(ADDR,FILEREAD,ISLL,LENGTH,MAXLENGTH,PLIFILL,STG,SUBSTR,UNSPEC)
BUILTIN,
Input_file FILE RECORD INPUT INT
ENV(CONSECUTIVE RECSIZE(1)),
Output_file FILE RECORD OUTPUT INT
ENV(CONSECUTIVE RECSIZE(62));
/* Ignore any file that cannot be found */
ON UNDF(Input_file)
GO TO Skip_file;
OPEN FILE(Input_file) TITLE('/'||Input_filename||',TYPE(U)');
OPEN FILE(Output_file) TITLE('/'||Output_filename||
',TYPE(TEXT),EA(N),APPEND(N)');
DO LOOP;
Output_record = '';
/* Make the output work area all low values */
CALL PLIFILL(ADDR(Decoded_bytes),'00'X,STG(Decoded_bytes));
/* Read an input work area */
Rec_len = FILEREAD(Input_file,ADDR(Decoded_bytes),STG(Decoded_bytes));
/* A short record means that's all that's left */
IF Rec_len < STG(Decoded_bytes) THEN
LEAVE;
/* Now encode each group of 6 bits as a byte */
DO p = 1 TO LENGTH(Decoded_bytes) - 5 BY 6;
UNSPEC(Output_byte) = '00'B || SUBSTR(Decoded_bytes,p,6);
Output_record ||= SUBSTR(Base64_xlate_table,Output_byte+1,1);
END;
/* Write the output work area to the output file */
WRITE FILE(Output_file) FROM(Output_record);
END;
IF Rec_len > 0 THEN
DO;
/* Encode each group of 6 bits as a byte */
DO p = 1 TO ISLL(Rec_len,3) BY 6;
UNSPEC(Output_byte) = '00'B || SUBSTR(Decoded_bytes,p,6);
Output_record ||= SUBSTR(Base64_xlate_table,Output_byte+1,1);
END;
IF LENGTH(Output_record) = MAXLENGTH(Output_record) THEN
DO;
WRITE FILE(Output_file) FROM(Output_record);
Output_record = '=';
END;
ELSE
Output_record ||= '=';
WRITE FILE(Output_file) FROM(Output_record);
END;
CLOSE FILE(Output_file),
FILE(Input_file);
Skip_file:
RETURN;
END BASE64_ENCODE;
%PAGE;
/* Internal subroutine to split a list of file names, delimited by
plus signs, into an array of distinct file names */
Split_concatenated_files:
PROC(File_list,Filename_array);
DCL File_list CHAR(*) NONASGN,
Filename_array(*) CHAR(*) VAR CTL;
DCL Filename_delim CHAR(1) VALUE('+'),
(i,d,p) BIN FIXED(31,0) UNSIGNED,
(HBOUND,LBOUND,LENGTH,MIN,SEARCH,SUBSTR,TALLY) BUILTIN;
/* Determine the no. of path/filenames in the list.
Allocate that many, with a suitable maximum length */
ALLOC Filename_array(1:TALLY(File_list,Filename_delim)+1)
CHAR(MIN(260,LENGTH(File_list)));
/* Start scan in column 1 */
p = 1;
/* Extract all but the last path/filename */
DO i = LBOUND(Filename_array,1) TO HBOUND(Filename_array,1) - 1;
/* Scan for a delimiter */
d = SEARCH(File_list,Filename_delim,p);
/* Extract that path/filename */
Filename_array(i) = SUBSTR(File_list,p,d-p);
/* Increment leftmost scan position */
p = d + 1;
END;
/* Take care of the last one */
Filename_array(HBOUND(Filename_array,1)) = SUBSTR(File_list,p);
RETURN;
END Split_concatenated_files;
END UUXXCODE;
