1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20 initiate: in: proc;
21
22
23
24
25
26
27
28
29 %include branch_status;
30
31 dcl names (99 ) 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
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);
136
137 call init;
138 end;
139 end;
140 end;
141 else do;
142 if got_refname then second_refname = "1"b;
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
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;
158
159 call init;
160 end;
161
162 RETURN: if all_sw then call clean_up;
163 return;
164
165 init: proc;
166
167
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
175 if code = error_table_$namedup then
176 if force_sw & ^forced then do;
177 forced = "1"b;
178 call term_$single_refname (refname, code);
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;
199 end;
200
201 else if long_sw then do;
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;
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;