1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18 linus_dtt:
19 proc (sci_ptr, lcb_ptr);
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65 ^L
66 %include linus_lcb;
67 %page;
68 %include linus_char_argl;
69 %page;
70 %include linus_select_info;
71 %page;
72 %include linus_arg_list;
73 %page;
74 %include mdbm_arg_list;
75 %page;
76 %include linus_temp_tab_names;
77 ^L
78 dcl sci_ptr ptr;
79
80 dcl KEY char (1) options (constant) int static init ("*");
81
82 dcl sel_items char (select_info.sel_items_len)
83 based (select_info.sel_items_ptr);
84 dcl table_name char (char_argl.arg.arg_len (1))
85 based (char_argl.arg.arg_ptr (1));
86 dcl temp_char char (mrds_data_$max_token_size + 1) varying;
87 dcl tmp_char char (char_argl.arg.arg_len (i))
88 based (char_argl.arg.arg_ptr (i));
89
90 dcl 1 arg_len_bits based,
91 2 pad bit (12) unal,
92 2 length bit (24);
93
94 dcl (test, val_key) bit (1);
95
96 dcl debug_switch bit (1) int static init ("0"b);
97
98 dcl (
99 e_ptr init (null),
100 env_ptr init (null),
101 rslt_ptr init (null)
102 ) ptr;
103
104 dcl (addr, char, fixed, index, length, null, rel, rtrim, substr, vclock)
105 builtin;
106
107 dcl cleanup condition;
108
109 dcl (code, icode, rel_index, out_code) fixed bin (35);
110
111 dcl (curr_pos, desc, i, l) fixed bin;
112
113 dcl initial_mrds_vclock float bin (63);
114
115 dcl (
116 linus_data_$dtt_id,
117 linus_error_$dtt_key_select,
118 linus_error_$dtt_max_tabs,
119 linus_error_$dtt_no_key,
120 linus_error_$dtt_not_valid,
121 linus_error_$no_db,
122 linus_error_$no_input_arg,
123 linus_error_$table_exist,
124 mrds_data_$max_temp_rels,
125 mrds_data_$max_token_size,
126 mrds_error_$undef_rel,
127 sys_info$max_seg_size
128 ) fixed bin (35) ext;
129
130 dcl cu_$generate_call entry (entry, ptr);
131 dcl dsl_$define_temp_rel entry options (variable);
132 dcl dsl_$get_rslt_info
133 entry (fixed bin (35), char (*), ptr, ptr, fixed bin (35));
134 dcl ioa_ entry options (variable);
135 dcl linus_convert_code entry (fixed bin (35), fixed bin (35), fixed bin (35));
136 dcl linus_translate_query$auto entry (ptr, ptr);
137 dcl mdb_display_data_value$ptr entry (ptr, ptr);
138 dcl ssu_$abort_line entry options (variable);
139 dcl ssu_$arg_count entry (ptr, fixed bin);
140 dcl ssu_$arg_ptr entry (ptr, fixed bin, ptr, fixed bin (21));
141 dcl work_area area (sys_info$max_seg_size) based (lcb.linus_area_ptr);
142 ^L
143 val_key = "0"b;
144 al_ptr, ca_ptr, char_ptr = null;
145
146 icode, code = 0;
147
148 if lcb.db_index = 0 then
149 call error (linus_error_$no_db, "");
150 else do;
151 call ssu_$arg_count (sci_ptr, nargs_init);
152 if nargs_init = 0
153 then call error (linus_error_$no_input_arg, "");
154 end;
155 allocate char_argl in (lcb.static_area);
156 on cleanup begin;
157 if ca_ptr ^= null
158 then free char_argl;
159 end;
160 do i = 1 to nargs_init;
161 call ssu_$arg_ptr (sci_ptr, i, char_argl.arg.arg_ptr (i), char_argl.arg.arg_len (i));
162 end;
163 if char_argl.nargs <= 1 then
164 call error (linus_error_$dtt_no_key, "");
165 if lcb.si_ptr = null then call linus_translate_query$auto (sci_ptr, lcb_ptr);
166 if lcb.si_ptr = null then return;
167 si_ptr = lcb.si_ptr;
168 if ^select_info.se_flags.val_dtt then
169 call error (linus_error_$dtt_not_valid, "");
170 if lcb.timing_mode then
171 initial_mrds_vclock = vclock;
172 call
173 dsl_$get_rslt_info (lcb.db_index, table_name, lcb.linus_area_ptr,
174 rslt_ptr, icode);
175 if lcb.timing_mode then
176 lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock;
177 if icode = 0 then
178 icode = linus_error_$table_exist;
179 if icode ^= mrds_error_$undef_rel then
180 call error (icode, table_name);
181 do i = 2 to char_argl.nargs;
182 if char_argl.arg_len (i) > mrds_data_$max_token_size then
183 call
184 error (linus_error_$dtt_key_select,
185 "^/" || tmp_char || " is longer than "
186 || char (mrds_data_$max_token_size) || " characters.");
187 temp_char = rtrim (tmp_char) || " ";
188 curr_pos = 1;
189 test = "0"b;
190 do while (curr_pos <= select_info.sel_items_len & ^test);
191 curr_pos = index (sel_items, temp_char);
192 if curr_pos > 0 then do;
193 curr_pos = curr_pos + length (temp_char) - 2;
194
195 val_key = "1"b;
196 test = "1"b;
197 if select_info.sel_items_len > curr_pos then
198 sel_items =
199 substr (sel_items, 1, curr_pos) || KEY
200 || substr (sel_items, curr_pos + 2);
201 else sel_items = substr (sel_items, 1, curr_pos) || KEY;
202 end;
203 else call error (linus_error_$dtt_key_select, "^/" || tmp_char);
204 end;
205 end;
206
207 if ^val_key then
208 call error (linus_error_$dtt_key_select, "");
209
210 rel_index = 0;
211 if lcb.ttn_ptr ^= null then do;
212 ttn_ptr = lcb.ttn_ptr;
213 do l = 1 to mrds_data_$max_temp_rels;
214 if temp_tab_names (l) = table_name then
215 rel_index = l;
216 end;
217 end;
218 else do;
219 allocate temp_tab_names in (lcb.static_area);
220 lcb.ttn_ptr = ttn_ptr;
221 do i = 1 to mrds_data_$max_temp_rels;
222 temp_tab_names (i) = "";
223 end;
224 end;
225 desc = 4 + select_info.nsevals;
226
227 num_ptrs = desc * 2;
228 allocate arg_list in (work_area);
229 arg_list.arg_des_ptr (desc) = addr (icode);
230 n_chars_init = 1;
231 allocate char_desc in (work_area);
232
233 arg_list.arg_des_ptr (num_ptrs) = addr (char_desc.fb_desc);
234
235 arg_list.arg_des_ptr (1) = addr (lcb.db_index);
236 arg_list.arg_des_ptr (desc + 1) = addr (char_desc.fb_desc);
237
238 arg_list.arg_count, arg_list.desc_count = num_ptrs;
239 arg_list.code = 4;
240 arg_list.pad = 0;
241
242
243 char_desc.arr.var (1) = addr (select_info.se_len) -> arg_len_bits.length;
244
245 arg_list.arg_des_ptr (2) = select_info.se_ptr;
246 arg_list.arg_des_ptr (desc + 2) = addr (char_desc.arr (1));
247
248 arg_list.arg_des_ptr (desc - 1) = addr (rel_index);
249 arg_list.arg_des_ptr (num_ptrs - 1) = addr (char_desc.fb_desc);
250
251 if select_info.nsevals ^= 0 then
252 do l = 1 to select_info.nsevals;
253 arg_list.arg_des_ptr (2 + l) = select_info.se_vals.arg_ptr (l);
254 arg_list.arg_des_ptr (2 + l + desc) = select_info.se_vals.desc_ptr (l);
255 end;
256
257 if debug_switch then do;
258 call ioa_ ("Selection expression:");
259 call
260 mdb_display_data_value$ptr (select_info.se_ptr,
261 addr (char_desc.arr (1)));
262 end;
263
264 if lcb.timing_mode then
265 initial_mrds_vclock = vclock;
266 call cu_$generate_call (dsl_$define_temp_rel, al_ptr);
267 if lcb.timing_mode then
268 lcb.mrds_time = lcb.mrds_time + vclock - initial_mrds_vclock;
269 if rel_index > mrds_data_$max_temp_rels then
270 call error (linus_error_$dtt_max_tabs, "");
271 if icode = 0 then
272 temp_tab_names (rel_index) = table_name;
273 else call error (icode, "");
274 do i = 2 to char_argl.nargs;
275 if char_argl.arg_len (i) > mrds_data_$max_token_size then
276 call
277 error (linus_error_$dtt_key_select,
278 "^/" || tmp_char || " is longer than "
279 || char (mrds_data_$max_token_size) || " characters.");
280 temp_char = rtrim (tmp_char) || "*";
281 curr_pos = 1;
282 test = "0"b;
283 curr_pos = index (sel_items, temp_char);
284 if curr_pos > 0 then do;
285 curr_pos = curr_pos + length (temp_char) - 2;
286
287 if select_info.sel_items_len > curr_pos then
288 sel_items =
289 substr (sel_items, 1, curr_pos) || " "
290 || substr (sel_items, curr_pos + 2);
291 else sel_items = substr (sel_items, 1, curr_pos) || " ";
292 end;
293 else call error (linus_error_$dtt_key_select, "^/" || tmp_char);
294 end;
295
296 if ca_ptr ^= null
297 then free char_argl;
298 return;
299 ^L
300 db_on:
301 entry;
302
303
304
305
306
307
308
309
310
311 debug_switch = "1"b;
312 return;
313 ^K
314 db_off:
315 entry;
316
317
318
319
320
321
322
323
324
325 debug_switch = "0"b;
326 return;
327 ^L
328 error:
329 proc (err_code, string);
330
331 dcl err_code fixed bin (35);
332 dcl string char (*);
333
334 if ca_ptr ^= null
335 then free char_argl;
336 call linus_convert_code (err_code, out_code, linus_data_$dtt_id);
337 call ssu_$abort_line (sci_ptr, out_code, string);
338
339 end error;
340
341 end linus_dtt;