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 mail_errfiles:           proc;
 12 
 13 /*     ENTRY DECLARATIONS     */
 14 
 15 dcl  get_wdir_ entry returns (char (168));                  /* wdir of err segs */
 16 dcl  (temp_string1, temp_string) char(32);
 17 dcl  hcs_$star_ entry (char (*) aligned, char (*) aligned, fixed bin (2), ptr,
 18      fixed bin, ptr, ptr, fixed bin (35));                  /* names of err segs */
 19 dcl  hcs_$fs_get_mode entry (ptr, fixed bin (5), fixed bin (35)); /* mailbox accessable ? */
 20 dcl  delete_$path entry (char (*) aligned, char (*), bit (6), char (*), fixed bin (35));
 21 dcl  continue_to_signal_  entry (fixed bin(35));
 22 dcl  find_condition_info_ entry (ptr, ptr, fixed bin(35));
 23 dcl  ioa_$ioa_stream      entry options (variable);
 24 dcl  com_err_ entry options(variable);
 25 dcl  mailbox_$close entry(fixed bin,fixed bin(35));
 26 dcl  mailbox_$get_mode_index entry(fixed bin,bit(*)aligned,fixed bin(35));
 27 dcl  mailbox_$open entry(char(*)aligned,char(*)aligned,fixed bin,fixed bin(35));
 28 dcl  mail entry options(variable);                          /* new mail, ring 1 mailboxes */
 29 dcl  old_mail entry options(variable);                      /* old mail, "mailbox" segments */
 30 dcl  hcs_$terminate_noname
 31      entry (ptr, fixed bin (35));                           /* mail went OK         */
 32 dcl  dprint_ entry (char (*) aligned, char (*) aligned, ptr, fixed bin (35));
 33 dcl  get_system_free_area_
 34      entry returns (ptr);                                   /* for hcs_$star        */
 35 dcl  hcs_$initiate_count entry (char (*) aligned, char (*) aligned, char (*), fixed bin (24),
 36      fixed bin (2), ptr, fixed bin (35));                   /* find mailbox of err causer */
 37 dcl  hcs_$delentry_seg entry (ptr, fixed bin (35));         /* no access, scratch err seg */
 38 
 39 /*     BUILTIN FUNCTIONS     */
 40 
 41 dcl (addr, after, before, null, substr) builtin;
 42 
 43 /*     BASED STRUCTURES     */
 44 
 45 dcl 1 box based (p) aligned,                                /* mailbox structure    */
 46     2 lock bit (36) aligned,
 47     2 nchr fixed bin,
 48     2 nmsg fixed bin,
 49     2 lins fixed bin,
 50     2 secret fixed bin,
 51     2 pad (3) fixed bin,
 52     2 b,
 53       3 yte (1000) bit (9) unaligned;
 54 
 55 dcl 1 in based (p) aligned,                                 /* used by initiate_seg    */
 56     2 put (1000)bit (9) unaligned;
 57 
 58 
 59 % include dprint_arg;
 60 dcl 1 entries (encount) aligned based (eptr),               /* for hcs_$star        */
 61     2 type bit (2) unaligned,
 62     2 nname bit (16) unaligned,
 63     2 nindex bit (18) unaligned;
 64 
 65 /*     MISCELLANEOUS DATA ITEMS AND POINTERS     */
 66 
 67 dcl  names (0:100) char (32) aligned based (nptr);          /* EF seg names from list_err */
 68 dcl  areap ptr init (null);                                 /* ptr to sys free area         */
 69 dcl  encount fixed bin (17);                                /* no of err seg names        */
 70 dcl  mseg_index fixed bin(17) init(0);                      /* index of ring 1 mailbox */
 71 dcl (eptr, delptr, nptr) ptr init (null);                   /* miscellaneous pointers       */
 72 dcl  xmode bit(36) aligned;                                 /* extended access on ring 1 mailbox */
 73 dcl  star_arg char (6) aligned init ("EF.**");              /* indicates all segs beg w EF. */
 74 dcl  mode fixed bin (5);                                    /* access mode                  */
 75 dcl  bmode bit (36) based (addr (mode));                    /* for testing mode             */
 76 dcl  ind fixed bin;                                         /* index of no of EF. segs      */
 77 dcl  dptr ptr init (null);                                  /* ptr to dprint buffer         */
 78 dcl  dir_name char(168) aligned int static                  /* directory in which to look for errfiles */
 79           init(">udd>SysDaemon>error_file");
 80 dcl  code fixed bin (35);                                   /* std error code ind           */
 81 dcl dirp char(168) aligned;                                 /* mailbox dirname */
 82 dcl  p ptr init (null);
 83 dcl enamep char(32) aligned;                                /* mailbox entry name */
 84 dcl  ec fixed bin (35);                                     /* std sys err code             */
 85 dcl  bitct fixed bin (24);                                  /* bitct of err causers mailbox */
 86 dcl (this_seg, cur_seg) char (70);                          /* name of seg in my directory  */
 87 dcl  cur_name char (22) aligned;                            /* err causers name             */
 88 dcl  error_table_$noentry fixed bin (35) ext;               /* in case no mailbox           */
 89 dcl  error_table_$no_dir fixed bin (35) ext;                /* sm dir in pth nm not spec    */
 90 dcl  error_table_$no_info fixed bin (35) ext;               /* not enuf acc to rtn any info */
 91 dcl  cur_proj char (9) aligned;                             /* err causers proj             */
 92 dcl  my_path char (168) aligned;                            /* pathname of seg in my wdir   */
 93 dcl  any_other condition;
 94 ^L
 95 /*     BEGIN PROGRAM EXECUTION     */
 96 
 97 
 98 
 99 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
100 /*                                                                                                           */
101 /*  Initialize all the components of the dprint_arg structure                                                */
102 /*                                                                                                           */
103 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
104 
105 
106           dpap = addr (dprint_arg_buf);                     /* set ptr to the dprint_ args  */
107           dpap -> dprint_arg.version = 1;                   /* the version no is one        */
108           dpap -> dprint_arg.copies  = 1;                   /* only one copy                */
109           dpap -> dprint_arg.delete  = 1;                   /* dprint and delete the seg    */
110           dpap -> dprint_arg.queue   = 3;                   /* no hurry, so print in Q 3    */
111           dpap -> dprint_arg.pt_pch  = 1;                   /* print it don't punch it      */
112           dpap -> dprint_arg.notify  = 1;                   /* don't bother to notify       */
113           dpap -> dprint_arg.output_module = 1;             /* tell again to print not punch*/
114           dpap -> dprint_arg.class   = "printer";           /* make it perfectly clear      */
115 
116 
117 
118 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
119 /*                                                                                                           */
120 /*  Get the name of the wdir containing the backup dump exceptions processed by list_err                     */
121 /*  Pick up any segment names beginning with EF. and store them in the variable 'names where they will       */
122 /*  be processed one at a time.  if there are no EF. segments today then quit till tomorrow                  */
123 /*                                                                                                           */
124 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
125 
126           areap = get_system_free_area_ ();
127           call hcs_$star_ (dir_name, star_arg, 11b, areap, encount, eptr, nptr, code);
128           if code ^= 0 then do;
129                call com_err_ (code, "mail_errfiles", "Error in obtaining error segments.");
130                go to fin;
131           end;
132 
133 
134 
135 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
136 /*                                                                                                           */
137 /*  For each un backed up segment, pick up the name, strip off the EF. prefis and parse out                  */
138 /*  the name and the project.                                                                                */
139 /*                                                                                                           */
140 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
141 
142           do ind = 1 to encount;
143                this_seg = nptr -> names (ind-1);
144                my_path = before(dir_name," ")||">"||this_seg;
145                cur_seg = after (this_seg, "EF.");
146                temp_string = cur_seg;
147                do while (index (temp_string, ".") ^= 0);
148                     temp_string1 = before (temp_string, ".");
149                     temp_string = after (temp_string, ".");
150                end;
151                     cur_name = temp_string1;
152                     cur_proj = temp_string;
153 
154 
155 
156 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
157 /*                                                                                                           */
158 /*  Check to see if this is the segment named EF.strange^line which is the storage place that list_err       */
159 /*  uses for all lines in the backup dump which it cannot recognize as normal processing.                    */
160 /*  If this is the strange^line segment it is bypassed and left in the directory so that it can be           */
161 /*  dprinted and examined for any serious problems.                                                          */
162 /*                                                                                                           */
163 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
164 
165              if cur_name = "strange" then go to fin;
166 
167 
168 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
169 /*                                                                                                           */
170 /*  Look for a ring 1 mailbox to mail this segment to. If mail cannot be sent to a ring 1 mailbox for any   */
171 /*  reason, either because no such mailbox exists or because of insufficient access, try sending to an old  */
172 /*  mailbox. If there is not enough information available to say whether an old mailbox exists,             */
173 /*  then assume that the receiver doesn't want to know about his un backed up segments and delete the        */
174 /*  segment from the wdir.  If there is no mailbox or if some directory in the pathname is missing, then     */
175 /*  dprint the segment and go get the next one if any.                                                       */
176 /*                                                                                                           */
177 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
178 
179                on condition(any_other) call default_handler;
180                dirp = ">udd>"||before (cur_proj, " ")||">"||before (cur_name, " ");
181                enamep = before(cur_name," ")||".mbx";
182                call mailbox_$open(dirp,enamep,mseg_index,code);
183                if mseg_index=0 then do;                     /* can't send to new mailbox */
184 
185 try_old:            enamep = "mailbox";
186                     call hcs_$initiate_count (dirp, enamep, "", bitct, 1, p, ec);
187                     if p=null then do;
188 
189                          if ec = error_table_$no_info then go to del_seg;
190                          else if ec = error_table_$noentry | ec = error_table_$no_dir then do;
191 print_it:
192                               dpap -> dprint_arg.dest = cur_proj;
193                               dpap -> dprint_arg.heading = cur_name;
194 
195                               call dprint_ (dir_name, ("EF."||before(cur_name, " ")||"."||cur_proj), dpap, code);
196                               go to fin;
197                          end;
198 
199 
200 
201 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
202 /*                                                                                                           */
203 /*  If there is a null pointer where the mailbox pointer should be then call com_err_ to say why and go      */
204 /*  to get the next entry.  If there is a valid pointer, check to see if we have access.  If we have been    */
205 /*  refused access assume the potential receiver doesn't want to hear from us and delete the segment         */
206 /*  and go get the next one.                                                                                 */
207 /*                                                                                                           */
208 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
209 
210                          call com_err_ (ec, "mail_errfiles", "Null pointer returned to mailbox ^a>^a",dirp,enamep);
211                          go to fin;
212                     end;
213                     call hcs_$fs_get_mode (p, mode, code);
214                     if ^substr (bmode, 33, 1) | ^substr (bmode, 35, 1) then do;
215 
216                          call hcs_$terminate_noname(p,code);
217 del_seg:
218                          call delete_$path (dir_name, this_seg, "000100"b, "mail_errfiles", code);
219                          if code ^= 0 then
220                               call com_err_ (code, "mail_errfiles", "Unsuccessful delete attempt of seg", "^a", my_path);
221                          go to fin;
222                     end;
223 
224 
225 
226 
227 
228 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
229 /*                                                                                                           */
230 /*  When we finally have access, see first if this is a real mailbox.  If it is not, go dprint               */
231 /*  the segment instead.  If this is a real mailbox, mail the segment at last, and go get the next           */
232 /*  one , if any.                                                                                            */
233 /*                                                                                                           */
234 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
235 
236                     if bitct > 0 then if p -> box.secret ^= 2962 then do;
237                                  call hcs_$terminate_noname (p, code);
238                                  go to print_it;
239                     end;
240                     call old_mail (my_path, before(cur_name, " "), before(cur_proj, " "));
241                     call hcs_$terminate_noname (p, ec);
242                     p = null;
243                end;
244 
245 
246 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *  */
247 /*                                                                                                    */
248 /*  There is a ring 1 mailbox. Check extended access and if insufficient, go back and try old mail.   */
249 /*  If we have append extended access (first bit), send mail and close the mailbox.                   */
250 /*                                                                                                    */
251 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *  */
252 
253 
254                else do;
255                     call mailbox_$get_mode_index(mseg_index,xmode,ec);
256                     if ec^=0 | ^substr(xmode,1,1) then do;
257                          call mailbox_$close(mseg_index,code);
258                          go to try_old;
259                     end;
260 
261                     call mail (my_path,before(cur_name," "),before(cur_proj," "));
262                     call mailbox_$close(mseg_index,code);
263                end;
264 fin:      end;
265 
266 default_handler:     proc;
267 
268 dcl 1 cond_info      aligned,
269       2 mcptr                 ptr,
270       2 version               fixed bin,
271       2 condition_name        char(32) varying,
272       2 infop                 ptr,
273       2 wcptr                 ptr,
274       2 loc_ptr               ptr,
275       2 flags        aligned,
276         3 crawlout            bit(1) unal,
277         3 pad1                bit(35) unal,
278 
279       2 pad_word              bit(36) aligned,
280       2 user_loc              ptr,
281       2 pad(4)                bit(36) aligned;
282 
283 
284 call find_condition_info_ (null, addr(cond_info), code);
285 if code ^= 0 then do;
286 
287      call ioa_$ioa_stream ("error_output", "Error: Unknown signal has been received.");
288      return;
289 end;
290 
291 if cond_info.condition_name = "alrm" then do;
292 
293 continue:
294      call continue_to_signal_ (code);
295      return;
296 end;
297 
298 if cond_info.condition_name = "cput" then go to continue;
299 if cond_info.condition_name = "linkage_error" then go to continue;
300 if cond_info.condition_name = "mme2" then go to continue;
301 if cond_info.condition_name = "quit" then go to continue;
302 if cond_info.condition_name = "command_error" then go to continue;
303 if cond_info.condition_name = "finish" then go to continue;
304 if cond_info.condition_name = "stack" then go to continue;
305 if cond_info.condition_name = "program_interrupt" then return;
306 
307 call hcs_$terminate_noname (p, code);
308 go to fin;
309 
310 end default_handler;
311 
312 
313 /*  This is the end                                                                                          */
314 
315 end;