1 /* ******************************************************
  2    *                                                    *
  3    *                                                    *
  4    * Copyright (c) 1972 by Massachusetts Institute of   *
  5    * Technology and Honeywell Information Systems, Inc. *
  6    *                                                    *
  7    *                                                    *
  8    ****************************************************** */
  9 
 10 exist_any: proc;
 11 
 12 /* this active function is used to determime the existence of any of a group
 13    of segments.  It accepts a number of star-laden names as arguments and returns 'true' in
 14    the last argument (tfval) if _^Ha_^Hn_^Hy such segments are found, and 'false' otherwise.
 15 
 16    Initial coding: JKlensin  18 Apr 72 (preliminary version)
 17    Revised for AML, JKlensin, 18 Feb 74
 18    */
 19 /* Copyright 1974 Massachusetts Institute of Technology */
 20 
 21 /* calls and variables to find arguments */
 22 dcl  cu_$af_arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)), /* to find an argument */
 23      cu_$af_return_arg ext entry (fixed bin, ptr, fixed bin, fixed bin (35)); /* to find output arg */
 24 dcl  nargs fixed bin,
 25      ai fixed bin,
 26      ap ptr,
 27      al fixed bin,
 28      tp ptr,                                                /* to 'tfval' */
 29      tl fixed bin,                                          /* length of 'tfval' */
 30      tfval char (tl) varying based (tp);                    /* true or false value */
 31 
 32 dcl  expand_path_ ext entry (ptr, fixed bin, ptr, ptr, fixed bin (35));
 33 
 34 dcl  hcs_$star_ ext entry (char (*), char (*), fixed bin (2), ptr,
 35      fixed bin, ptr, ptr, fixed bin (35));
 36 
 37 dcl (error_table_$nomatch,                                  /* entries not found */
 38      error_table_$noarg,                                    /* expected argument missing */
 39      error_table_$seg_not_found) fixed bin (35) static external;
 40 
 41 
 42 dcl  dir char (168),                                        /* directory name */
 43      starname char (32),                                    /* name containing stars */
 44      ecount fixed bin,                                      /* number of entries found by hcs_$star */
 45     (eptr, nptr) pointer init (null ()),                    /* pointers required as arguments to hcs_$star_ */
 46      ercd fixed bin (35);
 47 
 48 dcl  pname char (al) based (ap);                            /* user-supplied pathname to be checked */
 49 
 50 dcl  active_fnc_err_ ext entry options (variable);          /* for errors */
 51 
 52 /* the following declarations are to get around a bug in hcs_$star_. When the bug
 53    goes away (if ever, it has been there for 3 years), the areapointer to star_
 54    should be replaced with null(), and these declarations and all code marked >>>
 55    should be deleted */
 56 dcl  areap ptr,                                             /* to an allocation area */
 57      get_system_free_area_ entry () returns (ptr),          /* to find an area */
 58      freen_ entry (ptr),                                    /* to get rid of something in an area */
 59      cleanup condition;
 60 
 61 dcl (addr, null) builtin;
 62 
 63 /*        end of declarations ^L                   */
 64 
 65 
 66 
 67 /* get the argument count and the true/false value */
 68           call cu_$af_return_arg (nargs, tp, tl, ercd);     /* find output and number of inputs */
 69           if ercd ^= 0 then do;                             /* bad format */
 70                call active_fnc_err_ (ercd, "exist_any");
 71                return;
 72           end;
 73           else if nargs < 1 then do;
 74                call active_fnc_err_ (error_table_$noarg, "exist_any", "segment name");
 75                return;
 76           end;
 77 
 78 
 79 /* loop through the rest of the arguments , looking for a match */
 80 argloop:  do ai = 1 to nargs;
 81                call cu_$af_arg_ptr (ai, ap, al, ercd);
 82 
 83 /* find the directory name */
 84                call expand_path_ (ap, al, addr (dir), addr (starname), ercd);
 85                if ercd ^= 0 then do;
 86                     call active_fnc_err_ (ercd, "exist_any", pname);
 87                     return;
 88                end;
 89 
 90 /* >>> get an area and make sure it is cleaned up later */
 91                areap = get_system_free_area_ ();            /* >>> */
 92                on condition (cleanup) go to cret;           /* >>> go free them */
 93 
 94 /* now, check for components */
 95                call hcs_$star_ (dir, starname, 11b, areap, ecount, eptr, nptr, ercd);
 96                if ercd = 0 then do;                         /* no error, check entries */
 97 
 98                     if ecount ^= 0 then do;
 99                          tfval = "true";                    /* found one */
100                          go to cret;
101                     end;
102                end;
103                else if ercd = error_table_$nomatch then;
104                else if ercd = error_table_$seg_not_found then ;
105                else do;                                     /* other nonzero error code */
106                     call active_fnc_err_ (ercd, "exist_any", pname);
107                     go to cret;
108                end;
109 
110           end argloop;
111 
112 false:
113           tfval = "false";                                  /* if we get here, must have exhausted list without any names */
114 
115 /* come here to clean up and return */
116 cret:
117           if eptr ^= null () then call freen_ (eptr);       /* >>> free both blocks */
118           if nptr ^= null () then call freen_ (nptr);       /* >>> */
119           return;
120 
121      end exist_any;