1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    * Copyright (c) 1972 by Massachusetts Institute of        *
  6    * Technology and Honeywell Information Systems, Inc.      *
  7    *                                                         *
  8    *********************************************************** */
  9 
 10 
 11 encode: code: proc;
 12 
 13 /* Commands encode and decode, for enciphering and deciphering files given a key.
 14 
 15    Usage:
 16    encode path1A {path2A ... path1N path2N} {-key STR}
 17    where:
 18    1. path1A  is the pathname of a segment.
 19    2. path2A  is the optional pathname of the encoded result, with
 20    the suffix .code assumed. The default is path1A.code.
 21 
 22    decode path1A {path2A ... path1N path2N} {-key STR}
 23    where:
 24    1. path1A  is the pathname of a segment, with .code suffix assumed.
 25    2. path2A  is the optional pathname of the decoded result.
 26    The default is path1A without .code suffix.
 27 
 28    Written 07/06/79 by Steve Herbst */
 29 /* TR7458 Add -key 10/30/80 S. Herbst */
 30 /* Fixed to check for w permission on target before asking for key 10/26/82 S. Herbst */
 31 
 32 
 33 /* Enciphered and deciphered as arrays of fixed bin (71) word pairs */
 34 dcl  source_array (source_len) fixed bin (71) based (source_ptr);
 35 dcl  target_array (source_len) fixed bin (71) based (target_ptr);
 36 
 37 dcl 1 entries (ecount) aligned based (eptr),                /* for hcs_$star_ */
 38     2 type bit (2) unaligned,
 39     2 nnames bit (16) unaligned,
 40     2 nindex bit (18) unaligned;
 41 
 42 dcl  names (99 /* arbitrary */) char (32) aligned based (nptr); /* names from hcs_$star_ */
 43 
 44 dcl  arg char (arg_len) based (arg_ptr);
 45 dcl (dn, source_dn, target_dn) char (168);
 46 dcl (en, equal_en, match_en, source_en, star_en, target_en) char (32);
 47 dcl  command char (32);                                     /* "encode" or "decode" */
 48 dcl (buffer, buffer2) char (11);                            /* input key */
 49 
 50 dcl (encode_sw, got_key_sw, path2_sw) bit (1);
 51 
 52 dcl  error_table_$badopt fixed bin (35) ext;
 53 dcl  area area based (area_ptr);
 54 
 55 dcl (area_ptr, arg_ptr, eptr, nptr, source_ptr, target_ptr) ptr;
 56 
 57 dcl  key fixed bin (71);                                    /* encipher/decipher key */
 58 dcl  bit_count fixed bin (24);
 59 dcl (arg_count, ecount, i, j, source_len) fixed bin;
 60 dcl arg_len fixed bin (21);
 61 
 62 dcl  code fixed bin (35);
 63 dcl  error_table_$badstar fixed bin (35) ext;
 64 dcl  error_table_$entlong fixed bin (35) ext;
 65 dcl  error_table_$moderr fixed bin (35) ext;
 66 dcl  error_table_$no_w_permission fixed bin (35) ext;
 67 dcl  error_table_$sameseg fixed bin (35) ext;
 68 dcl  error_table_$zero_length_seg fixed bin (35) ext;
 69 
 70 dcl  check_star_name_$entry entry (char (*), fixed bin (35));
 71 dcl  com_err_ entry options (variable);
 72 dcl  com_err_$suppress_name entry options (variable);
 73 dcl  cu_$arg_count entry (fixed bin, fixed bin (35));
 74 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 75 dcl  decipher_ entry (fixed bin (71), dim (*) fixed bin (71), dim (*) fixed bin (71), fixed bin);
 76 dcl  encipher_ entry (fixed bin (71), dim (*) fixed bin (71), dim (*) fixed bin (71), fixed bin);
 77 dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
 78 dcl  get_equal_name_ entry (char (*), char (*), char (32), fixed bin (35));
 79 dcl  get_system_free_area_ entry returns (ptr);
 80 dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
 81 dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
 82 dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
 83 dcl  hcs_$star_ entry (char (*), char (*), fixed bin (2), ptr, fixed bin, ptr, ptr, fixed bin (35));
 84 dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
 85 dcl  hcs_$truncate_seg entry (ptr, fixed bin (19), fixed bin (35));
 86 dcl  pathname_ entry (char (*), char (*)) returns (char (168));
 87 dcl  read_password_ entry (char (*), char (*));
 88 
 89 dcl (divide, fixed, length, null, rtrim, substr, unspec) builtin;
 90 
 91 dcl  cleanup condition;
 92                                                             /* ^L */
 93           encode_sw = "1"b;
 94           command = "encode";
 95           go to COMMON;
 96 
 97 decode:   entry;
 98 
 99           encode_sw = "0"b;
100           command = "decode";
101 
102 COMMON:   call cu_$arg_count (arg_count, code);
103           if code ^= 0 then do;
104                call com_err_ (code, command);
105                return;
106           end;
107           if arg_count = 0 then do;
108                call com_err_$suppress_name (0, command,
109                     "Usage:  ^a path1A {path2A ... path1N path2N}", command);
110                return;
111           end;
112 
113           got_key_sw = "0"b;
114 
115           path2_sw = "0"b;
116           do i = 1 to arg_count;
117                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
118                if substr (arg, 1, 1) = "-" then
119                     if arg = "-key" then do;
120                          if got_key_sw then do;
121                               call com_err_ (0, command, "Attempt to specify two keys.");
122                               return;
123                          end;
124                          i = i + 1;
125                          if i > arg_count then do;
126                               call com_err_ (0, command, "No value specified for -key.");
127                               return;
128                          end;
129                          call cu_$arg_ptr (i, arg_ptr, arg_len, code);
130                          if arg_len > length (buffer) then do;
131                               call com_err_ (0, command, "Key longer than ^d characters.", length (buffer));
132                               return;
133                          end;
134                          buffer = arg;
135 
136 /* Calculate fixed bin (71) key */
137 
138                          call build_key (buffer, key);
139 
140                          arg_ptr = null;
141                          got_key_sw = "1"b;
142                     end;
143                     else do;
144                          call com_err_ (error_table_$badopt, command, "^a", arg);
145                          return;
146                     end;
147           end;
148 
149           do i = 1 to arg_count;
150                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
151                if substr (arg, 1, 1) = "-" then do;
152                     i = i + 1;
153                     go to END_LOOP;
154                end;
155 
156                call expand_pathname_ (arg, dn, en, code);
157                if code ^= 0 then do;
158                     call com_err_ (code, command, "^a", arg);
159                     return;
160                end;
161                if path2_sw then do;
162                     target_dn = dn;
163                     equal_en = en;
164 
165                     call cipher_stars;
166 
167                     path2_sw = "0"b;
168                end;
169                else do;
170                     source_dn = dn;
171                     star_en = en;
172                     path2_sw = "1"b;
173                end;
174 END_LOOP:
175           end;
176           if path2_sw then do;
177                target_dn = dn;
178                equal_en = "==";
179 
180                call cipher_stars;
181           end;
182 
183 RETURN:   return;
184                                                             /* ^L */
185 cipher_stars: proc;
186 
187 /* This internal procedure applies the star convention and calls cipher */
188 
189                call check_star_name_$entry (star_en, code);
190                if code = error_table_$badstar then do;
191                     call com_err_ (code, command, "^a", pathname_ (source_dn, star_en));
192                     go to RETURN;
193                end;
194                else if code = 0 then do;                    /* no stars */
195                     source_en = star_en;
196 
197                     call cipher;
198                     return;
199                end;
200 
201 /* Starname */
202 
203                eptr, nptr = null;
204 
205                on condition (cleanup) call star_clean_up;
206 
207                area_ptr = get_system_free_area_ ();
208                match_en = star_en;
209                if ^encode_sw then call append_code (match_en);
210 
211                call hcs_$star_ (source_dn, match_en, 3 /* all */, area_ptr, ecount, eptr, nptr, code);
212                if code ^= 0 then do;
213                     call com_err_ (code, command, "^a", pathname_ (source_dn, star_en));
214                     return;
215                end;
216 
217                do j = 1 to ecount;
218                     source_en = names (fixed (entries (j).nindex));
219                     if ^encode_sw then                      /* remove .code suffix */
220                          source_en = substr (source_en, 1, length (rtrim (source_en)) - 5);
221 
222                     call cipher;
223                end;
224 
225                call star_clean_up;
226 
227 star_clean_up: proc;
228 
229                     if eptr ^= null then free entries in (area);
230                     if nptr ^= null then free names in (area);
231 
232                end star_clean_up;
233 
234           end cipher_stars;
235                                                             /* ^L */
236 cipher:   proc;
237 
238 /* This internal procedure applies the equal convention and processes a single segment */
239 
240                call get_equal_name_ (source_en, equal_en, target_en, code);
241                if code ^= 0 then do;
242                     call com_err_ (code, command, "^a", equal_en);
243                     return;
244                end;
245 
246                if encode_sw then call append_code (target_en);
247                else call append_code (source_en);
248 
249                call hcs_$initiate_count (source_dn, source_en, "", bit_count, 0, source_ptr, code);
250                if source_ptr = null then do;
251 SOURCE_ERROR:       call com_err_ (code, command, "^a", pathname_ (source_dn, source_en));
252                     return;
253                end;
254                source_len = divide (bit_count + 71, 72, 18, 0); /* number of double words in segment */
255                if source_len = 0 then do;
256                     code = error_table_$zero_length_seg;
257                     go to SOURCE_ERROR;
258                end;
259                call hcs_$make_seg (target_dn, target_en, "", 01010b, target_ptr, code);
260                if target_ptr = null then do;
261 TARGET_ERROR:       call com_err_ (code, command, "^a", pathname_ (target_dn, target_en));
262                     return;
263                end;
264                call hcs_$truncate_seg (target_ptr, 0, code);
265                if code ^= 0 then do;
266                     if code = error_table_$moderr then code = error_table_$no_w_permission;
267                     go to TARGET_ERROR;
268                end;
269 
270                if source_ptr = target_ptr then do;
271                     code = error_table_$sameseg;
272                     go to SOURCE_ERROR;
273                end;
274 
275                if ^got_key_sw then do;
276                     buffer, buffer2 = "";
277 GET_KEY:            call read_password_ ("Key:", buffer);
278                     if encode_sw then do;
279                          call read_password_ ("Verify:", buffer2);
280                          if buffer ^= buffer2 then do;      /* twice to make sure */
281                               call com_err_ (0, "encode", "Keys do not match. Please try again.");
282                               go to GET_KEY;
283                          end;
284                     end;
285 
286 /* Generate a fixed bin (71) key */
287 
288                     call build_key (buffer, key);
289 
290                     buffer2 = "";
291                     got_key_sw = "1"b;
292                end;
293 
294                if encode_sw then call encipher_ (key, source_array, target_array, source_len);
295                else call decipher_ (key, source_array, target_array, source_len);
296 
297                call hcs_$set_bc_seg (target_ptr, bit_count, code);
298                call hcs_$terminate_noname (source_ptr, code);
299                call hcs_$terminate_noname (target_ptr, code);
300 
301           end cipher;
302 /*^L*/
303 append_code: proc (a_en);
304 
305 /* This internal procedure appends a .code suffix and checks for entlong */
306 
307 dcl a_en char (32);
308 
309           if length (rtrim (a_en)) + 5 > length (a_en) then do;
310                call com_err_ (error_table_$entlong, command, "^a.code", a_en);
311                go to RETURN;
312           end;
313 
314           a_en = rtrim (a_en) || ".code";
315 
316 end append_code;
317 %page;
318 build_key: proc (A_buffer, A_key);
319 
320 dcl A_buffer char (11);
321 dcl A_key fixed bin (71);
322 dcl k fixed bin;
323 dcl buffer_bits bit(99) unaligned;
324 dcl key_bits bit(72) unaligned;
325 
326 dcl 1 pack unaligned defined (key_bits),
327    2 bits (10) bit (7) unaligned,
328    2 pad bit (2) unaligned;
329 
330 dcl 1 strip unaligned defined (buffer_bits),
331    2 c (11) unaligned,
332     3 pad bit (2) unaligned,
333     3 bits bit (7) unaligned;
334 
335           unspec (buffer_bits) = unspec (A_buffer);
336 
337           do k = 1 to 10;
338                pack.bits (k) = strip.c (k).bits;
339           end;
340 
341           pack.pad = substr (strip.c (11).bits, 6, 2);
342           unspec (A_key) = unspec (key_bits);
343 
344           A_buffer = "";
345 
346 end build_key;
347 
348      end encode;
349