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 
 12 
 13 /****^  HISTORY COMMENTS:
 14   1) change(86-05-02,Elhard), approve(86-05-02,MCR7391),
 15      audit(86-07-18,DGHowe), install(86-11-20,MR12.0-1222):
 16      Modified to allow initiation of MSFs by initiating component 0 of the MSF.
 17                                                    END HISTORY COMMENTS */
 18 
 19 
 20 initiate: in: proc;
 21 
 22 /* The initiate command:
 23 
 24           initiate path {reference_names} {-control_args}
 25 
 26 Rewritten 01/11/80 by S. Herbst */
 27 
 28 
 29 %include branch_status;
 30 
 31 dcl names (99 /* arbitrary */) char (32) aligned based (names_ptr);
 32 
 33 dcl arg char (arg_len) based (arg_ptr);
 34 dcl (dn, act_dn) char (168);
 35 dcl (en, act_en, refname) char (32);
 36 
 37 dcl type fixed bin (2);
 38 dcl bc fixed bin (24);
 39 
 40 dcl area area based (area_ptr);
 41 
 42 dcl (all_sw, chase_sw, force_sw, forced, got_path, got_refname) bit (1);
 43 dcl (long_sw, second_refname, some_args) bit (1);
 44 
 45 dcl (area_ptr, arg_ptr, names_ptr, seg_ptr) ptr;
 46 
 47 dcl (arg_count, arg_len, i, j, names_count, segno) fixed bin;
 48 dcl code fixed bin (35);
 49 
 50 dcl error_table_$badopt fixed bin (35) ext;
 51 dcl error_table_$dirseg fixed bin (35) ext;
 52 dcl error_table_$namedup fixed bin (35) ext;
 53 dcl error_table_$segknown fixed bin (35) ext;
 54 
 55 dcl active_fnc_err_ entry options (variable);
 56 dcl (com_err_, com_err_$suppress_name) entry options (variable);
 57 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin, fixed bin (35));
 58 dcl cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35));
 59 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35));
 60 dcl get_system_free_area_ entry returns (ptr);
 61 dcl hcs_$initiate entry (char (*), char (*), char (*), fixed bin (1), fixed bin (2), ptr, fixed bin (35));
 62 dcl hcs_$status_ entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35));
 63 dcl hcs_$status_minf entry (char(*), char(*), fixed bin(1), fixed bin(2), fixed bin(24), fixed bin(35));
 64 dcl ioa_ entry options (variable);
 65 dcl term_$single_refname entry (char (*), fixed bin (35));
 66 
 67 dcl (addr, addrel, baseno, bin, fixed, null, rtrim, substr) builtin;
 68 
 69 dcl cleanup condition;
 70 /*^L*/
 71           call cu_$af_return_arg (arg_count, null, 0, code);
 72           if code = 0 then do;
 73                call active_fnc_err_ (0, "initiate", "Cannot be called as an active function.");
 74                return;
 75           end;
 76 
 77           all_sw, force_sw, long_sw, some_args = "0"b;
 78           chase_sw = "1"b;
 79           do i = 1 to arg_count;
 80 
 81                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
 82 
 83                if substr (arg, 1, 1) ^= "-" then some_args = "1"b;
 84 
 85                else if arg = "-all" | arg = "-a" then all_sw = "1"b;
 86                else if arg = "-brief" | arg = "-bf" then long_sw = "0"b;
 87                else if arg = "-long" | arg = "-lg" | arg = "-s" then long_sw = "1"b;
 88                else if arg = "-chase" then chase_sw = "1"b;
 89                else if arg = "-no_chase" then chase_sw = "0"b;
 90                else if arg = "-force" | arg = "-fc" then force_sw = "1"b;
 91                else if arg = "-no_force" | arg = "-nfc" then force_sw = "0"b;
 92                else do;
 93                     call com_err_ (error_table_$badopt, "initiate", "^a", arg);
 94                     return;
 95                end;
 96           end;
 97 
 98           if ^some_args then do;
 99                call com_err_$suppress_name (0, "initiate",
100                     "Usage:  initiate path {reference_names} {-control_args}");
101                return;
102           end;
103 
104           names_ptr = null;
105           got_path, got_refname, second_refname = "0"b;
106           do i = 1 to arg_count;
107 
108                call cu_$arg_ptr (i, arg_ptr, arg_len, code);
109 
110                if substr (arg, 1, 1) = "-" then go to NEXT_ARG;
111 
112                if ^got_path then do;
113                     call expand_pathname_ (arg, dn, en, code);
114                     if code ^= 0 then do;
115                          call com_err_ (code, "initiate", "^a", arg);
116                          return;
117                     end;
118                     got_path = "1"b;
119 
120                     if all_sw then do;
121                          got_refname = "1"b;
122                          area_ptr = get_system_free_area_ ();
123 
124                          on condition (cleanup) call clean_up;
125 
126                          call hcs_$status_ (dn, en, fixed (chase_sw, 1), addr (branch_status), area_ptr, code);
127                          if code ^= 0 then do;
128                               call com_err_ (code, "initiate",
129                                    "Unable to get names of ^a^[>^]^a", dn, dn ^= ">", en);
130                               return;
131                          end;
132                          names_ptr = addrel (area_ptr, branch_status.names_rel_pointer);
133                          names_count = bin (branch_status.number_names);
134                          do j = 1 to names_count;
135                               refname = names (j);          /* initiate by each name on seg */
136 
137                               call init;
138                          end;
139                     end;
140                end;
141                else do;                                     /* reference name specified */
142                     if got_refname then second_refname = "1"b;  /* err msg for first refname only */
143                     got_refname = "1"b;
144                     refname = arg;
145 
146                     if ^all_sw then call init;
147 
148                     else do;
149                          do j = names_count by -1 to 1 while (names (j) ^= refname); end;
150                                                             /* only do those names not already init'd by -all */
151                          if j = 0 then call init;
152                     end;
153                end;
154 NEXT_ARG: end;
155 
156           if ^got_refname then do;
157                refname = en;                                /* no refnames specified: initiate by entryname */
158 
159                call init;
160           end;
161 
162 RETURN:   if all_sw then call clean_up;
163           return;
164 /*^L*/
165 init: proc;
166 
167 /* This internal procedure initiates a segment by one reference name */
168 
169           forced = "0"b;
170 
171           act_dn = dn;
172           act_en = en;
173 INITIATE: call hcs_$initiate (act_dn, act_en, refname, 0, 0, seg_ptr, code);
174           if code ^= 0 & code ^= error_table_$segknown then  /* OK if seg already known by same name */
175                if code = error_table_$namedup then          /* a different seg known by this name */
176                     if force_sw & ^forced then do;
177                          forced = "1"b;
178                          call term_$single_refname (refname, code);  /* terminate old reference to refname */
179                          if code ^= 0 then call com_err_ (code, "initiate",
180                               "Unable to terminate reference name ^a", refname);
181                          else go to INITIATE;
182                     end;
183                     else call com_err_ (code, "initiate", "^a", refname);
184                else if code = error_table_$dirseg then do;
185                     call hcs_$status_minf (dn, en, 1, type, bc, code);
186                     if code = 0 & type = 2 & bc > 0 then do;
187                          act_dn = rtrim (dn) || ">" || en;
188                          act_en = "0";
189                          goto INITIATE;
190                     end;
191                     else do;
192                          call com_err_ (error_table_$dirseg, "initiate",  "^a^[>^]^a", dn, dn ^= ">", en);
193                          go to RETURN;
194                     end;
195                end;
196                else do;
197                     if ^second_refname then call com_err_ (code, "initiate", "^a^[>^]^a", dn, dn ^= ">", en);
198                     if seg_ptr = null then go to RETURN;    /* can't initiate the segment at all */
199                end;
200 
201           else if long_sw then do;                          /* success */
202                segno = bin (baseno (seg_ptr), 17);
203                call ioa_ ("^a>^a initiated with segment number ^o", dn, en, segno);
204                long_sw = "0"b;                              /* print only for first refname */
205           end;
206 
207 end init;
208 
209 
210 
211 
212 clean_up: proc;
213 
214           if names_ptr ^= null then free names in (area);
215           names_ptr = null;
216 
217 end clean_up;
218 
219 
220 end initiate;