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 /* Conditionally executes one of two command/request lines; as an active function/request, conditionally returns one of
 12    two strings */
 13 
 14 /* Created:  September 1970 by THVV */
 15 /* Modified: 27 April 1976 by Steve Herbst to accept keys "true" and "false" */
 16 /* Modified: 17 February 1982 by G. Palter to add ssu_if_request_ and convert to use a standalone subsystem invocation */
 17 /* Modified: 8 September 1982 by G. Palter to propogate subsystem/request line aborts */
 18 
 19 /* format: style4,delnl,insnl,ifthenstmt,ifthen */
 20 
 21 
 22 if:
 23      procedure () options (variable);
 24 
 25 
 26 dcl  P_sci_ptr pointer parameter;                           /* ssu_if_request_: -> SCI of subsystem */
 27 dcl  P_info_ptr pointer parameter;                          /* ssu_if_request_: -> subsystem's internal data */
 28 
 29 dcl  sci_ptr pointer;
 30 dcl  standalone_invocation bit (1) aligned;
 31 
 32 dcl  active_function bit (1) aligned;
 33 dcl  nargs fixed binary;
 34 
 35 dcl  return_string char (rl) varying based (rp);
 36 dcl  rl fixed binary (21);
 37 dcl  rp pointer;
 38 
 39 dcl  argument character (al) based (ap);
 40 dcl  al fixed binary (21);
 41 dcl  ap pointer;
 42 
 43 dcl  second_argument character (cl) based (cp);
 44 dcl  cl fixed binary (21);
 45 dcl  cp pointer;
 46 
 47 dcl  key character (8);
 48 dcl  an fixed binary;
 49 
 50 dcl  notsw bit (1) aligned;
 51 dcl  thenloc fixed binary;
 52 dcl  elseloc fixed binary;
 53 
 54 dcl  ec fixed binary (35);
 55 
 56 dcl  i fixed binary;
 57 dcl  (first_number, second_number) fixed binary (35);
 58 
 59 dcl  chase fixed binary (1);
 60 dcl  type fixed binary (2);
 61 dcl  bc fixed binary (24);
 62 dcl  dn character (168);
 63 dcl  en character (32);
 64 
 65 dcl  timestr character (24);
 66 
 67 dcl  yes_no_sw bit (1);
 68 
 69 dcl  error_table_$bad_conversion fixed binary (35) external;
 70 dcl  error_table_$noarg fixed binary (35) external;
 71 dcl  ssu_et_$null_request_line fixed binary (35) external;
 72 dcl  ssu_et_$subsystem_aborted fixed binary (35) external;
 73 
 74 dcl  active_fnc_err_ entry () options (variable);
 75 dcl  com_err_ entry () options (variable);
 76 dcl  command_query_$yes_no entry () options (variable);
 77 dcl  cu_$af_return_arg entry (fixed binary, pointer, fixed binary (21)) returns (fixed binary (35));
 78 dcl  cu_$arg_list_ptr entry () returns (pointer);
 79 dcl  cv_dec_check_ entry (character (*), fixed binary (35)) returns (fixed binary (35));
 80 dcl  date_time_ entry (fixed binary (71), character (*));
 81 dcl  expand_pathname_ entry (character (*), character (*), character (*), fixed binary (35));
 82 dcl  hcs_$status_minf
 83           entry (character (*), character (*), fixed binary (1), fixed binary (2), fixed binary (24), fixed binary (35));
 84 dcl  ssu_$abort_line entry () options (variable);
 85 dcl  ssu_$abort_subsystem entry () options (variable);
 86 dcl  ssu_$arg_ptr entry (pointer, fixed binary, pointer, fixed binary (21));
 87 dcl  ssu_$destroy_invocation entry (pointer);
 88 dcl  ssu_$execute_line entry (pointer, pointer, fixed binary (21), fixed binary (35));
 89 dcl  ssu_$get_subsystem_and_request_name entry (pointer) returns (character (72) varying);
 90 dcl  ssu_$get_request_name entry (pointer) returns (character (32));
 91 dcl  ssu_$return_arg entry (pointer, fixed binary, bit (1) aligned, pointer, fixed binary (21));
 92 dcl  ssu_$standalone_invocation entry (pointer, character (*), character (*), pointer, entry, fixed binary (35));
 93 
 94 dcl  cleanup condition;
 95 
 96 dcl  (clock, null, substr) builtin;
 97 
 98 /*^L*/
 99 
100 /* Multics if command/active-function */
101 
102 /* if: entry () options (variable); */
103 
104           standalone_invocation = "1"b;                     /* must create a standalone subsystem to do this */
105           call ssu_$standalone_invocation (sci_ptr, "if", "1.0", cu_$arg_list_ptr (), abort_if_command, ec);
106           if ec ^= 0 then do;                               /* please forgive the following, but ... */
107                if cu_$af_return_arg (0, (null ()), (0)) = 0 then
108                     call active_fnc_err_ (ec, "if", "Can not establish standalone subsystem invocation.");
109                else call com_err_ (ec, "if", "Can not establish standalone subsystem invocation.");
110                return;
111           end;
112           go to COMMON;
113 
114 
115 /* Standard subsystem if request */
116 
117 ssu_if_request_:
118      entry (P_sci_ptr, P_info_ptr);
119 
120           standalone_invocation = "0"b;                     /* caller supplied the subsystem */
121           sci_ptr = P_sci_ptr;
122           go to COMMON;
123 
124 
125 /* Actual work starts here */
126 
127 COMMON:
128           on condition (cleanup)
129                begin;
130                     if standalone_invocation then call ssu_$destroy_invocation (sci_ptr);
131                end;
132 
133           call ssu_$return_arg (sci_ptr, nargs, active_function, rp, rl);
134 
135           if nargs = 0 then                                 /* abort_line never returns */
136 PRINT_USAGE_MESSAGE:
137                if active_function then
138                     call ssu_$abort_line (sci_ptr, 0, "Usage:  [^a key -then {value1} {-else value2}]",
139                          ssu_$get_request_name (sci_ptr));
140                else call ssu_$abort_line (sci_ptr, 0,
141                          "Usage:  ^a key -then {^[command^;request^]1} {-else ^[command^;request^]2}",
142                          ssu_$get_request_name (sci_ptr), standalone_invocation, standalone_invocation);
143 
144           an = 2;                                           /* index of first argument after the key */
145           notsw = "0"b;                                     /* do not invert the test */
146           thenloc, elseloc = 0;                             /* no -then or -else yet */
147           chase = 1;                                        /* chase links by default */
148 
149 
150 /* Get the keyword */
151 
152           call ssu_$arg_ptr (sci_ptr, 1, ap, al);
153           key = argument;
154 
155           if key = "-not" then do;                          /* users wishes to invert the test */
156                notsw = "1"b;
157                an = an + 1;                                 /* next argument is the keyword */
158                call ssu_$arg_ptr (sci_ptr, 2, ap, al);
159                key = argument;
160           end;
161 
162           else if substr (key, 1, 1) = "^" then do;         /* users wises to invert the test */
163                key = substr (key, 2, 7);
164                notsw = "1"b;
165           end;
166 
167 
168 /* Locate then and else clauses (if any) and validate command/request syntax */
169 
170           do i = an to nargs;
171 
172                call ssu_$arg_ptr (sci_ptr, i, ap, al);
173 
174                if argument = "-then" then do;
175                     if thenloc ^= 0 then go to PRINT_USAGE_MESSAGE;
176                     thenloc = i;                            /* remember location of "-then" */
177                end;
178 
179                else if argument = "-else" then do;
180                     if elseloc ^= 0 then go to PRINT_USAGE_MESSAGE;
181                     elseloc = i;                            /* remember location of "-else" */
182                end;
183           end;
184 
185           if thenloc = 0 then go to PRINT_USAGE_MESSAGE;    /* -then must be supplied */
186 
187           if elseloc > 0 then do;                           /* -else must follow -then with, at most, one ... */
188                if elseloc < thenloc then go to PRINT_USAGE_MESSAGE;
189                if elseloc > (thenloc + 2) then go to PRINT_USAGE_MESSAGE;
190                if (elseloc + 1) ^= nargs then go to PRINT_USAGE_MESSAGE;
191           end;                                              /* ... intervening argument and must be followed by one */
192 
193           else do;                                          /* -then alone: it may be followed by no more than one arg */
194                if nargs > (thenloc + 1) then go to PRINT_USAGE_MESSAGE;
195           end;
196 
197 
198 /* Determine results of the key (execution/no-execution) */
199 
200           if key = "true" then go to RESULT_IS_TRUE;        /* key was an active string */
201 
202           if key = "false" then go to RESULT_IS_FALSE;      /* key was an active string */
203 
204           if key = "is" then do;                            /* check that a branch (seg/MSF/dir) exists */
205 CHECK_ENTRY_EXISTENCE:
206                if an = thenloc then                         /* no pathname was supplied */
207                     call ssu_$abort_line (sci_ptr, error_table_$noarg, "Pathname after ""^a"".", key);
208                call ssu_$arg_ptr (sci_ptr, an, ap, al);
209                call expand_pathname_ (argument, dn, en, ec);
210                if ec ^= 0 then go to STATUS_MINF_CALL_FAILS;/* bad pathname: same as no entry */
211                if key = "islink" then chase = 0;            /* look for a link */
212                if key = "isfile" then chase = 0;            /* look for a segment */
213                if key = "isdir" then chase = 0;             /* look for a directory */
214                call hcs_$status_minf (dn, en, chase, type, bc, ec);
215                if ec ^= 0 then
216 STATUS_MINF_CALL_FAILS:                                     /* entry does not exist */
217                     if key = "isnt" then
218                          go to RESULT_IS_TRUE;
219                     else go to RESULT_IS_FALSE;
220                if key = "is" then go to RESULT_IS_TRUE;     /* entry is there */
221                if key = "isnt" then go to RESULT_IS_FALSE;  /* entry is there: asked if it wasn't */
222                if key = "isdir" then                        /* looking for a directory */
223                     if type = 2 then go to RESULT_IS_TRUE;
224                if key = "islink" then                       /* looking for a link */
225                     if type = 0 then go to RESULT_IS_TRUE;
226                if key = "isfile" then                       /* looking for a segment */
227                     if type = 1 then go to RESULT_IS_TRUE;
228                if key = "isnzf" then                        /* looking for a non-zero length segment */
229                     if (type = 1) & (bc > 0) then go to RESULT_IS_TRUE;
230                go to RESULT_IS_FALSE;                       /* here iff test failed */
231           end;
232 
233           else if key = "isnt" then go to CHECK_ENTRY_EXISTENCE;
234                                                             /* check for non-existence of a branch */
235           else if key = "isfile" then go to CHECK_ENTRY_EXISTENCE;
236                                                             /* check for existence of a segment */
237           else if key = "isdir" then go to CHECK_ENTRY_EXISTENCE;
238                                                             /* check for existence of a directory */
239           else if key = "islink" then go to CHECK_ENTRY_EXISTENCE;
240                                                             /* check for existence of a link */
241           else if key = "isnzf" then go to CHECK_ENTRY_EXISTENCE;
242                                                             /* check for existence of a non-zero length segment */
243 
244           else if key = "arg" then                          /* check for an argument after the key and before -then */
245                if an = thenloc then
246                     go to RESULT_IS_FALSE;
247                else go to RESULT_IS_TRUE;
248 
249           else if key = "noarg" then                        /* check that no argument follows key */
250                if an = thenloc then
251                     go to RESULT_IS_TRUE;
252                else go to RESULT_IS_FALSE;
253 
254           else if key = "day" then do;                      /* check the date: arg after key is day name or day of month */
255                if an = thenloc then go to RESULT_IS_FALSE;
256                call ssu_$arg_ptr (sci_ptr, an, ap, al);
257                call date_time_ (clock (), timestr);         /* read the clock */
258                if substr (argument, 1, 1) > "A" then        /* alphabetic: check day of week */
259                     if substr (argument, 1, 3) = substr (timestr, 22, 3) then
260                          go to RESULT_IS_TRUE;
261                     else go to RESULT_IS_FALSE;
262                else if argument = substr (timestr, 4, 2) then go to RESULT_IS_TRUE;
263                else go to RESULT_IS_FALSE;
264           end;
265 
266           else if key = "argeq" then do;                    /* check two arguments after key for equality */
267                if an = thenloc then go to RESULT_IS_TRUE;   /* ... neither given */
268                if an = (thenloc - 1) then go to RESULT_IS_FALSE;
269                                                             /* ... only one is given: can't be equal */
270                call ssu_$arg_ptr (sci_ptr, an, ap, al);
271                call ssu_$arg_ptr (sci_ptr, (an + 1), cp, cl);
272                if argument = second_argument then
273                     go to RESULT_IS_TRUE;
274                else go to RESULT_IS_FALSE;
275           end;
276 
277           else if key = "ask" then do;                      /* ask a question */
278                if an = thenloc then                         /* ... question was already typed */
279                     call command_query_$yes_no (yes_no_sw, 0, ssu_$get_subsystem_and_request_name (sci_ptr), "", "?");
280                else do;                                     /* ... pickup question after the key */
281                     call ssu_$arg_ptr (sci_ptr, an, ap, al);
282                     call command_query_$yes_no (yes_no_sw, 0, ssu_$get_subsystem_and_request_name (sci_ptr), "", argument)
283                          ;
284                end;
285                if yes_no_sw then
286                     go to RESULT_IS_TRUE;
287                else go to RESULT_IS_FALSE;
288           end;
289 
290           else if key = "less" then do;                     /* numerical checks */
291 NUMERICAL_COMPARISONS:
292                if an = thenloc then go to RESULT_IS_FALSE;  /* both arguments must be there */
293                if an = (thenloc - 1) then go to RESULT_IS_FALSE;
294                call ssu_$arg_ptr (sci_ptr, an, ap, al);
295                first_number = cv_dec_check_ (argument, ec);
296                if ec ^= 0 then
297 NON_NUMERIC_ARGUMENT:
298                     call ssu_$abort_line (sci_ptr, error_table_$bad_conversion, "^a", argument);
299                call ssu_$arg_ptr (sci_ptr, (an + 1), ap, al);
300                second_number = cv_dec_check_ (argument, ec);
301                if ec ^= 0 then go to NON_NUMERIC_ARGUMENT;
302                if first_number < second_number then
303                     if key = "less" then
304                          go to RESULT_IS_TRUE;
305                     else go to RESULT_IS_FALSE;
306                else if first_number > second_number then
307                     if key = "less" then
308                          go to RESULT_IS_FALSE;
309                     else go to RESULT_IS_TRUE;
310                else go to RESULT_IS_FALSE;                  /* no check for equality on numbers */
311           end;
312 
313           else if (key = "greater") | (key = "grt") then go to NUMERICAL_COMPARISONS;
314 
315           else if key = "number" then do;                   /* check that argument after key is a number */
316                if an = thenloc then go to RESULT_IS_FALSE;  /* ... not there */
317                call ssu_$arg_ptr (sci_ptr, an, ap, al);
318                first_number = cv_dec_check_ (argument, ec);
319                if ec = 0 then
320                     go to RESULT_IS_TRUE;
321                else go to RESULT_IS_FALSE;
322           end;
323 
324           else call ssu_$abort_line (sci_ptr, 0, "Unknown keyword ""^a"".", key);
325 
326 
327 /* Result of the test was false */
328 
329 RESULT_IS_FALSE:
330           if notsw then go to RESULT_IS_REALLY_TRUE;        /* sense of test was reversed */
331 
332 RESULT_IS_REALLY_FALSE:
333           if elseloc = 0 then go to RETURN_FROM_IF;         /* no else clause */
334           an = elseloc + 1;                                 /* find where else clause is */
335           go to EXECUTE_OR_RETURN_STRING;
336 
337 
338 /* Result of the test was true */
339 
340 RESULT_IS_TRUE:
341           if notsw then go to RESULT_IS_REALLY_FALSE;       /* sense of the test was reversed */
342 
343 RESULT_IS_REALLY_TRUE:
344           an = thenloc + 1;                                 /* argument index of then clause (if present) */
345           if an = elseloc then go to RETURN_FROM_IF;        /* a null then clause */
346 
347 
348 /* Execute/return the selected string */
349 
350 EXECUTE_OR_RETURN_STRING:
351           if an > nargs then go to RETURN_FROM_IF;          /* clause is not present */
352 
353           call ssu_$arg_ptr (sci_ptr, an, ap, al);
354 
355           if active_function then                           /* active function/request: return the string */
356                return_string = argument;
357           else do;                                          /* command/request: execute it */
358                if al > 0 then call ssu_$execute_line (sci_ptr, ap, al, ec);
359                if ^standalone_invocation & (ec ^= 0) & (ec ^= ssu_et_$null_request_line) then
360                     if ec = ssu_et_$subsystem_aborted then
361                          call ssu_$abort_subsystem (sci_ptr);
362                     else call ssu_$abort_line (sci_ptr);
363           end;
364 
365 
366 /* Clean up */
367 
368 RETURN_FROM_IF:
369           if standalone_invocation then                     /* we created the invocation */
370                call ssu_$destroy_invocation (sci_ptr);
371 
372           return;
373 
374 
375 
376 /* Internal procedure invoked by ssu_$abort_line when if was invoked as a Multics command/active function */
377 
378 abort_if_command:
379      procedure ();
380 
381           go to RETURN_FROM_IF;                             /* message has been printed: now we can punt */
382 
383      end abort_if_command;
384 
385      end if;