1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(1986-06-02,Herbst), approve(1986-06-02,MCR7432),
 17      audit(1986-06-30,Wong), install(1986-06-30,MR12.0-1080):
 18      Fixed to zero unused portions of mail_format.
 19   2) change(1987-02-26,Lippard), approve(1987-03-18,MECR0001),
 20      audit(1987-03-12,Fawcett), install(1987-03-19,MR12.1-1002):
 21      Modified to strip control characters from message comment field.
 22   3) change(1987-05-08,Lippard), approve(1987-04-20,MCR7669),
 23      audit(1987-05-11,Fawcett), install(1987-05-20,MR12.1-1032):
 24      Formal installation to close out MECR0001.
 25   4) change(2020-01-30,Swenson), approve(2020-01-30,MCR10070),
 26      audit(2020-01-30,GDixon), install(2020-01-30,MR12.6g-0036):
 27      Fix reference through null pointer.
 28                                                    END HISTORY COMMENTS */
 29 
 30 
 31 mail: ml: proc;
 32 
 33 /* Usage:
 34    mail                                           to read own mail
 35    mail -path-                                    to read any mail
 36    mail  path  user1^H_ proj1^H_ ... user_^Hi proj_^Hi                to send a segment
 37    mail   *    user1^H_ proj1^H_ ... user_^Hi proj_^Hi                to send console input
 38 
 39    Mailbox names end in ".mbx"          */
 40 
 41 
 42 /* -notify and -no_notify added 7/27/78 by S. Herbst */
 43 /* Modified: 1 May 1985 by G. Palter to remove reference to mseg_hdr.incl.pl1 */
 44 
 45 % include mail_format;        /* this based structure should call the ASCII part "text" */
 46 dcl 1 send_mail_info aligned,                               /* structure for sending acknowledgement message */
 47     2 version fixed bin,                                    /* = 1 */
 48     2 from char (32) aligned,
 49     2 switches,
 50       3 wakeup bit (1) unal,
 51       3 mbz1 bit (1) unal,
 52       3 always_add bit (1) unal,
 53       3 never_add bit (1) unal,
 54       3 mbz2 bit (1) unal,
 55       3 acknowledge bit (1) unal,
 56       3 mbz bit (30) unal;
 57 
 58 dcl  area area based (areap);
 59 
 60 dcl  segment char (4096) based (segp);
 61 dcl  page char (4096) aligned;
 62 dcl  node_space (48) ptr aligned;                           /* space for first 24 deletion nodes */
 63 
 64 dcl  alphabet char (256) init                               /* alphabetics plus BS HT NL RRS BRS */
 65     ((8)" " || "^H
 66 " || (3)" " || "^N^O" || (16)" " || substr (collate (), 33));
 67 dcl  BS char (1) internal static options (constant) init ("^H");
 68 dcl (buffer, dn) char (168);
 69 dcl (en, last_sender, last_sent_from, sender, sender_name) char (32);
 70 dcl  atime char (24);
 71 dcl (match_person, match_project) char (32) init ("*");
 72 dcl (exclude_person, exclude_project) char (32) init (".");
 73 dcl  name char (22);
 74 dcl  proj char (9);
 75 dcl  vname char (22) varying;
 76 dcl  vproj char (9) varying;
 77 dcl  last_date char (8);
 78 dcl  command char (7);
 79 dcl  answer char (3) varying;
 80 dcl  s char (1) init ("");
 81 dcl  nlx char (1);
 82 dcl  newline char (1) init ("
 83 ");
 84 
 85 dcl  arg char (al) based (ap);
 86 
 87 dcl  node (24) char (16) aligned based (stack_ptr);         /* deletion nodes */
 88 
 89 dcl  stack_bits bit (3456) aligned based (stack_ptr);
 90 dcl  clock bit (54) aligned;
 91 dcl  exmode bit (36) aligned;
 92 dcl (acknowledge,                                           /* request acknowledgement when sending */
 93      brief,                                                 /* -brief option when reading */
 94      head_mode,                                             /* -header mode when reading */
 95      dont_print_count,
 96      console,                                               /* sending console input */
 97      got_input,                                             /* already copied into "page" */
 98      more,                                                  /* more input in input mode */
 99      my_mbx,                                                /* reading from user's own mailbox */
100      notify_sw,                                             /* send notification with the mail */
101      own,                                                   /* reading own messages */
102      path_sw,                                               /* read mail by pathname */
103      pdir_flag,                                             /* save mail in process directory */
104      printing,                                              /* printing mail */
105      salvaged,                                              /* mailbox was salvaged */
106      saved,                                                 /* already saved in unsent_mail */
107      seg_initiated)                                         /* initiated a segment to send */
108      bit (1) aligned init ("0"b);
109 
110 dcl (al, anonymous, arg_count, argno, chars, header_length, i, msg_bitcnt, nlines) fixed bin;
111 dcl (count, mseg_index) fixed bin init (0);
112 dcl  node_index fixed bin init (0);
113 dcl (last_type, interactive init (1), mail_type init (2)) fixed bin;
114 dcl (five_minutes, last_time, time) fixed bin (71);
115 dcl  bitcnt fixed bin (24);
116 dcl  j fixed bin (21);
117 dcl  mode fixed bin (5);
118 dcl  chase fixed bin (1) init (1);
119 
120 dcl (ap, argp, idp, node_ptr) pointer;
121 dcl (areap, mbxp, segp) pointer init (null);
122 dcl  stack_ptr ptr;
123 
124 dcl 1 id_node aligned based,
125     2 next pointer aligned,
126     2 delete_id bit (72) aligned;                           /* message id saved for deletion */
127 
128 dcl 1 mseg_return_args aligned,
129     2 msg_ptr pointer,                                      /* -> returned message */
130     2 bitcnt fixed bin (18),                                /* bit count of message */
131     2 sender_id char (32),                                  /* sender's group id */
132     2 level fixed bin,                                      /* validation level */
133     2 id bit (72),                                          /* loc_and_time */
134     2 sender_authorization bit (72),
135     2 access_class bit (72);
136 
137 dcl 1 query_info aligned internal static,
138     2 vsn fixed bin init (1),
139     2 yes_or_no_sw bit (1) unaligned init ("1"b),
140     2 suppress_name_sw bit (1) unaligned init ("0"b),
141     2 status_code fixed bin (35) init (0),
142     2 query_code fixed bin (35) init (0);
143 
144 dcl  canonicalize_ entry (ptr, fixed bin(21), ptr, fixed bin(21), fixed bin(35));
145 dcl  com_err_ entry options (variable);
146 dcl  command_query_ entry options (variable);
147 dcl  cu_$arg_count entry (fixed bin);
148 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
149 dcl  cu_$grow_stack_frame entry (fixed bin, ptr, fixed bin (35));
150 dcl  date_time_ entry (fixed bin (71), char (*));
151 dcl  expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
152 dcl  expand_pathname_$add_suffix entry (char (*), char (*), char (*), char (*), fixed bin (35));
153 dcl  get_system_free_area_ entry returns (ptr);
154 dcl  get_pdir_ entry returns (char (168)aligned);
155 dcl  get_wdir_ entry returns (char (168)aligned);
156 dcl hcs_$delentry_file entry (char (*), char (*), fixed bin (35));
157 dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35));
158 dcl  hcs_$initiate_count entry (char (*), char (*), char (*), fixed bin (24), fixed bin (2), ptr, fixed bin (35));
159 dcl  hcs_$make_seg entry (char (*), char (*), char (*), fixed bin (5), ptr, fixed bin (35));
160 dcl  hcs_$set_bc_seg entry (ptr, fixed bin (24), fixed bin (35));
161 dcl  hcs_$terminate_noname entry (ptr, fixed bin (35));
162 dcl  ioa_ entry options (variable);
163 dcl  ioa_$nnl entry options (variable);
164 dcl  ioa_$rsnnl entry options (variable);
165 dcl  iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
166 dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
167 dcl  iox_$user_input pointer external;
168 dcl  iox_$user_output pointer external;
169 dcl  send_mail_ entry (char (*)aligned, char (*)aligned, ptr, fixed bin (35));
170 dcl  send_message_$notify_mail entry (char (*), char (*), fixed bin (35));
171 dcl  user_info_ entry (char (*));
172 dcl  user_info_$login_data entry (char (*), char (*), char (*), fixed bin);
173 dcl  mailbox_$add_index entry (fixed bin, ptr, fixed bin, bit (72)aligned, fixed bin (35));
174 dcl  mailbox_$check_salv_bit_index entry (fixed bin, bit (1)aligned, bit (1)aligned, fixed bin (35));
175 dcl  mailbox_$close entry (fixed bin (17), fixed bin (35));
176 dcl  mailbox_$create entry (char (*), char (*), fixed bin (35));
177 dcl  mailbox_$delete_index entry (fixed bin, bit (72)aligned, fixed bin (35));
178 dcl  mailbox_$get_mode_index entry (fixed bin, bit (*)aligned, fixed bin (35));
179 dcl  mailbox_$incremental_read_index entry (fixed bin, ptr, bit (2), bit (72)aligned, ptr, fixed bin (35));
180 dcl  mailbox_$open entry (char (*), char (*), fixed bin, fixed bin (35));
181 dcl  mailbox_$open_if_full entry (char (*), char (*), bit (1) aligned,
182      fixed bin (17), fixed bin (17), fixed bin (35));
183 dcl  mailbox_$own_incremental_read_index entry (fixed bin, ptr, bit (2), bit (72)aligned, ptr, fixed bin (35));
184 dcl  mailbox_$own_read_index entry (fixed bin, ptr, bit (1), ptr, fixed bin (35));
185 dcl  mailbox_$read_index entry (fixed bin, ptr, bit (1), ptr, fixed bin (35));
186 dcl  mailbox_$update_message_index entry (fixed bin, fixed bin, bit (72)aligned, ptr, fixed bin (35));
187 
188 
189 dcl  code fixed bin (35);
190 dcl  error_table_$bad_segment fixed bin (35) external;
191 dcl  error_table_$badopt fixed bin (35) external;
192 dcl  error_table_$long_record fixed bin (35) external;
193 dcl  error_table_$moderr fixed bin (35) external;
194 dcl  error_table_$noentry fixed bin (35) external;
195 dcl  error_table_$no_message fixed bin (35) external;
196 dcl  error_table_$root fixed bin (35) ext;
197 dcl  error_table_$rqover fixed bin (35) external;
198 
199 dcl (cleanup, no_write_permission, program_interrupt, record_quota_overflow) condition;
200 
201 dcl (addr, bin, collate, divide, fixed, index, length, min, null) builtin;
202 dcl (rel, reverse, rtrim, search, size, substr, translate, unspec, verify) builtin;
203                                                             /* ^L */
204           mail_format_ptr = null;
205           on condition (cleanup) call mail_cleanup;
206           command = "mail";
207           call cu_$arg_count (arg_count);
208           buffer = "";
209           path_sw = "0"b;
210           do i = 1 to arg_count;
211                call cu_$arg_ptr (i, ap, al, code);
212                if substr (arg, 1, 1) = "-" then
213                     if arg = "-brief" | arg = "-bf" then brief = "1"b;
214                     else if arg = "-header" | arg = "-he" then head_mode = "1"b;
215                     else if arg = "-match" then do;
216                          dont_print_count = "1"b;
217                          i = i + 1;
218                          if i>arg_count then do;
219                               call com_err_ (0, command, "No value specified for -match");
220                               return;
221                          end;
222                          call cu_$arg_ptr (i, ap, al, code);
223                          j = index (arg, ".");
224                          if j = 0 then match_person = arg;
225                          else do;
226                               match_person = substr (arg, 1, j-1);
227                               match_project = substr (arg, j+1);
228                          end;
229                     end;
230                     else if arg = "-exclude" | arg = "-ex" then do;
231                          dont_print_count = "1"b;
232                          i = i + 1;
233                          if i>arg_count then do;
234                               call com_err_ (0, command, "No value specified for -exclude");
235                               return;
236                          end;
237                          call cu_$arg_ptr (i, ap, al, code);
238                          j = index (arg, ".");
239                          if j = 0 then exclude_person = arg;
240                          else do;
241                               exclude_person = substr (arg, 1, j-1);
242                               exclude_project = substr (arg, j+1);
243                          end;
244                     end;
245                     else if arg = "-acknowledge" | arg = "-ack" then go to SEND;
246                     else if arg = "-notify" | arg = "-nt" then go to SEND;
247                     else if arg = "-no_notify" | arg = "-nnt" then go to SEND;
248                     else if arg = "-pathname" | arg = "-pn" then do;
249                          if buffer ^= "" then go to SEND;
250                          i = i+1;
251                          if i>arg_count then do;
252                               call com_err_ (0, command, "No value specified for -pathname");
253                               return;
254                          end;
255                          call cu_$arg_ptr (i, ap, al, code);
256                          buffer = arg;
257                          path_sw = "1"b;
258                     end;
259                     else do;
260                          call com_err_ (error_table_$badopt, command, "^a", arg);
261                          return;
262                     end;
263                else if buffer ^= "" then go to SEND;
264                else buffer = arg;
265           end;
266           if buffer = "" then do;
267 
268 /* Read from default mailbox */
269 
270 READ:          my_mbx = "1"b;
271                bitcnt = 0;
272                call user_info_$login_data (name, proj, "", anonymous);
273                if anonymous = 1 then do;                    /* anonymous user */
274                     dn = ">udd>" || rtrim (proj) || ">anonymous";
275                     en = "anonymous.mbx";
276                end;
277                else do;
278                     dn = ">udd>" || rtrim (proj) || ">" || name;
279                     en = rtrim (name) || ".mbx";
280                end;
281                call mailbox_$open_if_full (dn, en, salvaged, count, mseg_index, code);
282                if code = error_table_$noentry then do;
283 
284 /* Create a new mailbox */
285 
286                     on condition (record_quota_overflow) begin;
287                          call com_err_ (error_table_$rqover, command, "Unable to create default mailbox.");
288                          go to RETURN;
289                     end;
290 
291                     call mailbox_$create (dn, en, code);
292                     if code ^= 0 then do;
293                          call com_err_ (code, command, "Unable to create default mailbox.");
294                          go to RETURN;
295                     end;
296 
297                     revert condition (record_quota_overflow);
298 
299                     call ioa_ ("^a>^a created. No mail.", dn, en);
300                     return;
301                end;
302           end;
303           else do;
304 
305 /* Read from specified mailbox */
306 
307                if buffer = ">" then do;
308                     code = error_table_$root;
309                     go to ERROR2;
310                end;
311                else if search (buffer, "<>") ^= 0 | path_sw then do; /* mbx pathname */
312                     call expand_pathname_$add_suffix (buffer, "mbx", dn, en, code);
313                     if code ^= 0 then go to ERROR2;
314                end;
315                else do;                                     /* Person.Project destination */
316                     i = index (buffer, ".");
317                     if i = 0 then do;
318                          call com_err_ (0, command, "No project specified for ^a", buffer);
319                          return;
320                     end;
321                     call ioa_$rsnnl (">udd>^a>^a", dn, 168, substr (buffer, i+1), substr (buffer, 1, i-1));
322                     en = substr (buffer, 1, i-1)||".mbx";
323                end;
324                call mailbox_$open_if_full (dn, en, salvaged, count, mseg_index, code);
325           end;
326 
327           if code ^= 0 & (code ^= error_table_$moderr | mseg_index = 0) then go to ERROR1;
328 
329           if salvaged then do;
330                if my_mbx then call mailbox_$check_salv_bit_index (mseg_index, "1"b, salvaged, code);
331                call ioa_ ("Mailbox ^a^[>^]^a has been salvaged since mail was last read.
332 Messages may have been lost.", dn, dn ^= ">", en);
333           end;
334           if code = 0 then do;
335                if count = 0 then do;
336                     if ^brief then
337                          call ioa_ ("No mail.");
338                     go to CLOSE;
339                end;
340                if count>1 then s = "s";                     /* plural */
341                if ^dont_print_count then
342                     call ioa_ ("^d message^a.", count, s);
343                if brief then go to CLOSE;
344           end;
345 
346           areap = get_system_free_area_ ();
347           argp = addr (mseg_return_args);
348 
349           call mailbox_$read_index (mseg_index, areap, "0"b, argp, code); /* read earliest message first */
350           if code ^= 0 then
351                if code = error_table_$no_message then do;
352                     if ^brief then call ioa_ ("No mail.");
353                     go to CLOSE;
354                end;
355                else if code = error_table_$moderr then own = "1"b;
356                else go to ERROR1;
357 
358           if own then do;
359                call mailbox_$own_read_index (mseg_index, areap, "0"b, argp, code);
360                if code ^= 0 then if code = error_table_$no_message then do;
361                          if ^brief then call ioa_ ("You have no messages in ^a^[>^]^a.", dn, dn ^= ">", en);
362                          go to CLOSE;
363                     end;
364                     else go to ERROR1;
365                else if brief then do;
366                     call ioa_ ("You have messages in ^a^[>^]^a", dn, dn ^= ">", en);
367                     go to CLOSE;
368                end;
369                else call ioa_ ("^/Your messages:^/");
370           end;
371 
372           printing = "1"b;
373 
374           on condition (program_interrupt) begin;           /* pi turns off printing */
375                printing = "0"b;
376                go to REMEMBER;
377           end;
378 
379           last_type = mail_type;                            /* initialize some variables */
380           last_sender, last_date = "";
381           last_time = 0;
382           five_minutes = (3*10**8)* (2**18);
383           idp, stack_ptr = addr (node_space);
384           idp -> stack_bits = "0"b;
385 
386           do count = 1 by 1 while (code = 0);               /* if a message is deleted while in this loop,
387                                                                all messages after it won't get printed.
388                                                                They will appear with next "mail". */
389                mail_format_ptr = msg_ptr;
390 
391                if ^printing then go to REMEMBER;
392 
393                clock = substr (id, 19, 54);
394                unspec (time) = clock;
395                call date_time_ (bin (clock, 71), atime);
396                if lines ^= 1 then s = "s";
397                else s = "";
398                i = index (mseg_return_args.sender_id, " "); /* remove instance tag */
399                if i = 0 then i = 33;
400                sender = substr (mseg_return_args.sender_id, 1, i-3);
401                j = index (sender, ".");
402                if exclude_person = "*" | exclude_person = substr (sender, 1, j-1) then go to RNEXT;
403                if exclude_project = "*" | exclude_project = substr (sender, j+1) then go to RNEXT;
404                if match_person ^= "*" & match_person ^= substr (sender, 1, j-1) then go to RNEXT;
405                if match_project ^= "*" & match_project ^= substr (sender, j+1) then go to RNEXT;
406                if head_mode then nlx = ""; else nlx = newline;
407 
408                if mail_format.wakeup then do;               /* interractive message */
409                     if last_type = mail_type then do;
410                          call ioa_ ("");
411                          last_sender = "";
412                     end;
413                     if sender = last_sender & sent_from = last_sent_from & ^head_mode then do;
414                          if time-last_time>five_minutes then
415                               if substr (atime, 1, 8) ^= last_date then call ioa_$nnl ("=:(^a) ", atime);
416                               else call ioa_$nnl ("=:(^a) ", substr (atime, index (atime, ".")-4, 6));
417                          else call ioa_$nnl ("=: ");
418                     end;
419                     else if sent_from = "" | sent_from = sender
420                     | sent_from = substr (sender, 1, length (sender)-index (reverse (sender), ".")) then
421                          call ioa_ ("^aMessage from ^a  ^a:", nlx, sender, atime);
422                     else call ioa_ ("^aMessage from ^a (^a)  ^a:", nlx, sender, rtrim (canon (rtrim (sent_from), length (rtrim (sent_from)))), atime);
423                     last_type = interactive;
424                     last_sender = sender;
425                     last_sent_from = sent_from;
426                     last_time = time;
427                     last_date = substr (atime, 1, 8);
428                end;
429 
430                else do;
431                     last_type = mail_type;
432                     if sent_from = "" | sent_from = sender
433                     | sent_from = substr (sender, 1, length (sender)-index (reverse (sender), "."))
434                     then call ioa_ ("^a^d) From: ^a  ^a^[ (^d line^a)^;^s^s^]^a",
435                          nlx, count, sender, atime, (lines > 0), lines, s, nlx);
436                     else call ioa_ ("^a^d) From: ^a (^a)  ^a^[ (^d line^a)^;^2s^]^a",
437                          nlx, count, rtrim (canon (rtrim (sent_from), length (rtrim (sent_from)))), sender, atime, (lines > 0), lines, s, nlx);
438                end;
439 
440 /* Print the message */
441 
442                if ^head_mode then do;
443                     i = 1;
444                     do while (i <= mail_format.text_len);
445                          j = min (mail_format.text_len-i+1, length (buffer));
446                          buffer = rtrim (canon (substr (mail_format.text, i, j), length (substr (mail_format.text, i, j))));
447                          call iox_$put_chars (iox_$user_output, addr (buffer), j, code);
448                          i = i+j;
449                     end;
450                     if substr (buffer, j, 1) ^= newline then call ioa_ ("");
451 
452 /* Acknowledge the message */
453 
454                     if mail_format.acknowledge then do;
455 
456                          send_mail_info.version = 1;
457                          send_mail_info.from = "";
458                          send_mail_info.wakeup = "1"b;
459                          send_mail_info.mbz1 = "0"b;
460                          send_mail_info.always_add = "1"b;
461                          send_mail_info.never_add = "0"b;
462                          send_mail_info.mbz2 = "0"b;
463                          send_mail_info.acknowledge = "0"b;
464                          send_mail_info.mbz = "0"b;
465                          clock = substr (mseg_return_args.id, 19, 54);
466                          unspec (time) = clock;
467                          call date_time_ (bin (clock, 71), atime);
468                          i = length (mseg_return_args.sender_id)+1-verify (reverse (mseg_return_args.sender_id), " ");
469 
470                          call send_mail_ (substr (mseg_return_args.sender_id, 1, i-2),
471                               "Acknowledge message of "||atime, addr (send_mail_info), code);
472 
473                          mail_format.acknowledge = "0"b;    /* turn off acknowledge bit in message */
474                          call mailbox_$update_message_index (mseg_index,
475                               36 * (fixed (rel (addr (mail_format.text)))-fixed (rel (addr (mail_format.version)))),
476                               mseg_return_args.id, mseg_return_args.msg_ptr, code);
477                     end;
478                end;
479 
480 /* Remember to delete later */
481 
482 REMEMBER:      if ^head_mode then do;
483                     call get_id_node;
484                     idp -> id_node.next = node_ptr;
485                     idp = node_ptr;
486                     idp -> id_node.next = null;
487                     idp -> id_node.delete_id = id;
488                end;
489 
490 /* Read the next message */
491 
492 RNEXT:         free mail_format in (area);
493 
494                if own then call mailbox_$own_incremental_read_index (mseg_index, areap, "01"b, id, argp, code);
495                else call mailbox_$incremental_read_index (mseg_index, areap, "01"b, id, argp, code);
496 
497           end;
498 
499           revert condition (program_interrupt);
500           on condition (program_interrupt) go to QUERY;
501 
502           if code ^= error_table_$no_message then go to ERROR1;
503 
504 QUERY:    if node_index = 0 then answer = "no";
505           else call command_query_ (addr (query_info), answer, command, "Delete?");
506           revert condition (program_interrupt);
507           if answer ^= "yes" then go to CLOSE;
508 
509           count = 0;
510           idp = addr (node_space);
511           do while (idp ^= null);
512                count = count+1;
513                call mailbox_$delete_index (mseg_index, idp -> id_node.delete_id, code);
514                if code ^= 0 then do;
515                     call com_err_ (code, command, "Message ^d not deleted.", count);
516                     code = 0;
517                end;
518                idp = idp -> id_node.next;
519           end;
520 
521           go to CLOSE;
522                                                             /* ^L */
523 /* Send mail */
524 
525 SEND:     notify_sw = "1"b;
526           do i = 1 to arg_count;
527                call cu_$arg_ptr (i, ap, al, code);
528                if substr (arg, 1, 1) = "-" then             /* look for control arguments */
529                     if arg = "-acknowledge" | arg = "-ack" then acknowledge = "1"b;
530                     else if arg = "-notify" | arg = "-nt" then notify_sw = "1"b;
531                     else if arg = "-no_notify" | arg = "-nnt" then notify_sw = "0"b;
532                     else if arg ^= "-pathname" & arg ^= "-pn" then do;
533                          call com_err_ (error_table_$badopt, "mail", "^a", arg);
534                          return;
535                     end;
536           end;
537 
538           on condition (record_quota_overflow) begin;       /* from adding a message */
539                call com_err_ (error_table_$rqover, command,
540                     "Unable to add message to mailbox ^a^[>^]^a", dn, dn ^= ">", en);
541                call save;
542                go to RETURN;
543           end;
544 
545           argno = 1;
546 GET_PATH: call cu_$arg_ptr (argno, ap, al, code);
547           if code ^= 0 then go to SKIP_PATH;
548           argno = argno+1;
549           if substr (arg, 1, 1) = "-" then go to GET_PATH;
550           buffer = arg;
551           if buffer = ">" then do;
552                code = error_table_$root;
553                go to ERROR2;
554           end;
555 SKIP_PATH:
556           text_length = 0;
557           mail_format_ptr = null;
558           call user_info_ (sender_name);
559 
560 SEND_LOOP:
561           call cu_$arg_ptr (argno, ap, al, code);
562           if code ^= 0 then do;                             /* Normal exit - no more destinations */
563 CLEANUP:       call mail_cleanup;
564                return;
565           end;
566           if substr (arg, 1, 1) = "-" then
567                if arg = "-pathname" | arg = "-pn" then do;
568                     argno = argno + 1;
569                     call cu_$arg_ptr (argno, ap, al, code);
570                     if code ^= 0 then do;
571                          call com_err_ (0, command, "No value specified for -pathname");
572                          return;
573                     end;
574                     call expand_pathname_$add_suffix (arg, "mbx", dn, en, code);
575                     if code ^= 0 then do;
576                          call com_err_ (code, command, "^a", arg);
577                          return;
578                     end;
579                     go to OPEN;
580                end;
581                else do;
582                     argno = argno+1;
583                     go to SEND_LOOP;
584                end;
585           i = index (arg, ".");
586           if i ^= 0 then do;                                /* Person.Project destination */
587                argno = argno-1;
588                name, vname = substr (arg, 1, i-1);
589                proj, vproj = substr (arg, i+1);
590           end;
591           else do;
592                name, vname = arg;
593 GET_PROJ:      call cu_$arg_ptr (argno+1, ap, al, code);
594                if code ^= 0 then do;
595 NO_PROJ:            call com_err_ (0, command, "No project name specified for ^a.", vname);
596                     call save;
597                     return;
598                end;
599                if substr (arg, 1, 1) = "-" then
600                     if arg = "-pathname" | arg = "-pn" then go to NO_PROJ;
601                     else do;
602                          argno = argno+1;
603                          go to GET_PROJ;
604                     end;
605                proj, vproj = arg;                           /* project id for concatenating */
606           end;
607           en = vname || ".mbx";
608           dn = ">udd>" || vproj || ">" || vname;
609 
610 OPEN:     call mailbox_$open (dn, en, mseg_index, code);    /* get index of mailbox */
611           if code ^= 0 then do;
612                call com_err_ (code, command, "^a^[>^]^a", dn, dn ^= ">", en);
613                call save;
614                go to NEXT;
615           end;
616           else do;
617                call mailbox_$get_mode_index (mseg_index, exmode, code); /* get effective access to mailbox */
618                if ^substr (exmode, 1, 1) then do;           /* no "a" access */
619                     call com_err_ (0, command,
620                          "Insufficient access to send to ^a^[>^]^a", dn, dn ^= ">", en);
621                     call save;
622                     go to NEXT;
623                end;
624           end;
625 
626           if ^got_input then do;                            /* copy the message in once */
627 
628                areap = get_system_free_area_ ();
629 
630                nlines = 0;
631                if buffer = "*" then do;                     /* console input */
632                     console = "1"b;
633                     got_input = "1"b;
634                     segp = addr (page);
635 
636                     on condition (program_interrupt) begin; /* pi saves what is typed so far and quits */
637                          call save;
638                          go to CLOSE;
639                     end;
640 
641                     call ioa_ ("Input:");
642 
643                     more = "1"b;
644                     do while (more);
645                          call iox_$get_line (iox_$user_input, addr (buffer), 168, j, code);
646                          if code ^= 0 then if code ^= error_table_$long_record then do;
647                                    call save;
648                                    buffer = "user_input";
649                                    go to ERROR2;
650                               end;
651 
652                          if j = 2 & substr (buffer, 1, 1) = "." then more = "0"b; /* dot ends input mode */
653                          else do;
654                               if text_length+j>4096 then do;
655                                    call com_err_ (0, command, "Message cannot be longer than 1 record.");
656                                    call save;
657                                    return;
658                               end;
659                               if code ^= error_table_$long_record then nlines = nlines + 1;
660                               substr (segp -> segment, text_length+1, j) = substr (buffer, 1, j); /* copy the line in */
661                               text_length = text_length+j;
662                          end;
663                     end;
664 
665                     revert condition (program_interrupt);
666                     if nlines = 0 then return;
667                     bitcnt = text_length*9;
668                end;
669                else do;                                     /* input is a segment */
670                     got_input = "1"b;
671                     call expand_pathname_ (rtrim (buffer), dn, en, code);
672                     if code ^= 0 then go to ERROR2;
673 
674                     call hcs_$initiate_count (dn, en, "", bitcnt, 1, segp, code);
675                     if segp = null then go to ERROR1;
676 
677                     seg_initiated = "1"b;
678 
679                     call hcs_$fs_get_mode (segp, mode, code); /* see if access to read */
680                     if mode<1000b then if code = 0 then do;
681                               call com_err_ (0, command, "Need ""r"" access to ^a^[>^]^a", dn, dn ^= ">", en);
682                               call hcs_$terminate_noname (segp, code);
683                               go to CLOSE;
684                          end;
685                     text_length = divide (bitcnt+8, 9, 17, 0);
686                     chars = text_length;
687                     if text_length>4096 then do;
688                          call com_err_ (0, command, "Message cannot be longer than 1 record.");
689                          go to CLOSE;
690                     end;
691                     count = 1;
692 NL_LOOP:            i = index (substr (segp -> segment, count, chars), newline);
693                     if i>0 then do;
694                          count = count+i;
695                          chars = chars-i;
696                          nlines = nlines+1;                 /* count newlines in input segment */
697                          go to NL_LOOP;
698                     end;
699                end;
700           end;
701 
702           allocate mail_format in (area) set (mail_format_ptr);
703           header_length = size (mail_format)-divide (text_length, 4, 17, 0);
704           mail_format.version = MAIL_FORMAT_VERSION_4;
705           mail_format.sent_from = sender_name;              /* login name */
706           mail_format.lines = nlines;
707           mail_format.acknowledge = acknowledge;
708           mail_format.wakeup, mail_format.urgent, mail_format.seen, mail_format.others = "0"b;
709           mail_format.text = substr (segp -> segment, 1, text_length);
710           msg_bitcnt = bitcnt+36*header_length;             /* total bit count includes header */
711 
712           call mailbox_$add_index (mseg_index, mail_format_ptr, msg_bitcnt, id, code); /* try to add the message */
713           if code ^= 0 then
714                if code = error_table_$bad_segment then go to ERROR1;
715                else do;
716                     call com_err_ (code, command,
717                          "Unable to add message to mailbox ^a^[>^]^a", dn, dn ^= ">", en);
718                     call save;
719                end;
720 
721           else if notify_sw then call send_message_$notify_mail (name, proj, code); /* send notification */
722 
723 NEXT:     argno = argno+2;                                  /* on to the next pair */
724           call mailbox_$close (mseg_index, code);
725           go to SEND_LOOP;
726                                                             /* ^L */
727                                                             /* save a message in working_dir>unsent_mail */
728 
729 save:     proc;
730 
731                if saved then return;                        /* do not save twice */
732                if ^console | ^got_input then return;
733                if text_length = 0 then return;
734                saved = "1"b;
735                dn = get_wdir_ ();
736 
737                on condition (record_quota_overflow) begin;  /* from unsent_mail */
738                     call hcs_$delentry_file (dn, "unsent_mail", code);
739                     if ^pdir_flag then go to TRY_PDIR;
740                     call com_err_ (error_table_$rqover, command,
741                          "Unable to save message in unsent_mail.");
742                     go to CLEANUP;
743                end;
744 
745 CREATE:        call hcs_$make_seg (dn, "unsent_mail", "", 1011b, mbxp, code);
746                if mbxp = null then do;
747                     if ^pdir_flag then go to TRY_PDIR;
748                     call com_err_ (code, command, "Unable to save message in unsent_mail.");
749                     go to CLOSE;
750                end;
751 
752                on condition (no_write_permission) begin;
753                     if ^pdir_flag then go to TRY_PDIR;
754                end;
755 
756                substr (mbxp -> segment, 1, text_length) = substr (segp -> segment, 1, text_length);
757 
758                bitcnt = text_length*9;
759                call hcs_$set_bc_seg (mbxp, bitcnt, code);
760 
761                if pdir_flag then call ioa_ ("Text was saved in unsent_mail in process directory.");
762                else call ioa_ ("Text was saved in unsent_mail.");
763 
764                return;
765 
766 
767 TRY_PDIR:      pdir_flag = "1"b;
768                dn = get_pdir_ ();
769                go to CREATE;
770 
771           end save;
772                                                             /* ^L */
773 ERROR1:   if code = error_table_$bad_segment then do;
774                call com_err_ (code, command,
775                     "^a^[>^]^a^/Mailbox has been salvaged. Try again.", dn, dn ^= ">", en);
776                call save;
777           end;
778           else call com_err_ (code, command, "^a^[>^]^a", dn, dn ^= ">", en);
779           go to CLOSE;
780 
781 ERROR2:   call com_err_ (code, command, "^a", buffer);
782 
783 CLOSE:    if ^my_mbx & mseg_index ^= 0 then call mailbox_$close (mseg_index, code);
784           if seg_initiated then call hcs_$terminate_noname (segp, code);
785 
786 RETURN:   return;
787 
788 
789 /* This procedure removes control characters (except backspace, tab,
790    red ribbon shift, and black ribbon shift) and canonicalizes strings
791    to prevent backspacing past the front of the string. */
792 canon: procedure (P_string, P_string_len) returns (char (*));
793           dcl     P_string               char (*) parm;
794           dcl     P_string_len           fixed bin (21) parm;
795           dcl     output_string          char (P_string_len);
796 
797           P_string = translate (P_string, alphabet);
798           if index (P_string, BS) ^= 0 then do;
799                     output_string = "";
800                     call canonicalize_ (addr (P_string), length (P_string), addr (output_string), P_string_len, (0));
801                     return (output_string);
802                end;
803           else return (P_string);
804      end canon;
805 
806 get_id_node: proc;
807 
808                node_index = node_index+1;
809                if node_index>24 then do;                    /* allocate another block of 24 */
810                     call cu_$grow_stack_frame (96, stack_ptr, code);
811                     stack_bits = "0"b;
812                     node_index = 1;
813                end;
814                node_ptr = addr (node (node_index));
815 
816           end get_id_node;
817 
818 
819 mail_cleanup: proc;
820 
821                if mail_format_ptr ^= null then free mail_format in (area);
822                if mbxp ^= null then call hcs_$terminate_noname (mbxp, code);
823                if ^my_mbx & mseg_index ^= 0 then call mailbox_$close (mseg_index, code);
824                if seg_initiated then call hcs_$terminate_noname (segp, code);
825 
826           end mail_cleanup;
827 
828      end mail;