1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) Honeywell Bull Inc., 1987                *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         *********************************************************** */
  8 
  9 
 10 
 11 /****^  HISTORY COMMENTS:
 12   1) change(80-10-31,Herbst), approve(), audit(), install():
 13      TR6700 Add uppercase -leading 10/31/80 S. Herbst
 14   2) change(83-10-03,Spitzer), approve(), audit(), install():
 15      TR11275 correct error msg for cpch 10/03/83 C. Spitzer
 16   3) change(84-01-03,Loepere), approve(), audit(), install():
 17      use ioa_ for bce compatibility 01/03/84 K. Loepere
 18   4) change(85-01-04,Lippard), approve(85-01-23,MCR7151),
 19      audit(85-11-07,Spitzer), install(86-02-21,MR12.0-1024):
 20      Add reverse_substr 01/04/85 Jim Lippard
 21                                                    END HISTORY COMMENTS */
 22 
 23 
 24 substr:   procedure;
 25 
 26      dcl
 27           Larg (3)                      fixed bin,
 28           Lret                          fixed bin,
 29           Nargs                         fixed bin,
 30           Npic                          pic "(10)z9",
 31           Parg (3)                      ptr,
 32           Pret                          ptr,
 33           Scommand                      bit (1) aligned,
 34           arg_ptr                       entry (fixed bin, ptr, fixed bin, fixed bin(35)) variable,
 35           args_sw                       bit (1),
 36           bit3                          bit(3) aligned,
 37           bit4                          bit(4) aligned,
 38           char3                         char(3) aligned,
 39           char4                         char(4) aligned,
 40          (cleanup, conversion)          condition,
 41           code                          fixed bin(35),
 42           e                             fixed bin,
 43           error                         entry options (variable) variable,
 44          (i, j, n)                      fixed bin,
 45           leading_sw                    bit (1);
 46 
 47      dcl
 48           arg1                          char(Larg(1)) based (Parg(1)),
 49           arg2                          char(Larg(2)) based (Parg(2)),
 50           arg3                          char(Larg(3)) based (Parg(3)),
 51           ret                           char(Lret) varying based (Pret);
 52 
 53      dcl (addr, after, before, bit, bool, character, collate, collate9, convert, copy, decat,
 54           high, high9, index, length, low, ltrim, min, null, reverse, rtrim, search,
 55           substr, translate, verify)
 56                                         builtin;
 57 
 58      dcl
 59           active_fnc_err_               entry options (variable),
 60           com_err_                      entry options (variable),
 61          (cu_$af_return_arg,
 62           cu_$af_arg_ptr,
 63           cu_$arg_ptr)                  entry (fixed bin, ptr, fixed bin, fixed bin(35)),
 64           cu_$arg_count                 entry returns (fixed bin),
 65          (get_temp_segment_,
 66           release_temp_segment_)        entry (char(*), ptr, fixed bin(35)),
 67           ioa_                          entry() options(variable);
 68 
 69      dcl
 70           UP_A                          char (2) int static options (constant) init ("^a"),
 71           UPPERCASE                     char (26) aligned int static options (constant) init
 72                                                   ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"),
 73           LOWERCASE                     char (26) aligned int static options (constant) init
 74                                                   ("abcdefghijklmnopqrstuvwxyz"),
 75          (error_table_$bad_arg,
 76           error_table_$bad_conversion,
 77           error_table_$badopt,
 78           error_table_$wrong_no_of_args)
 79                                         fixed bin(35) ext static,
 80 
 81           ep (28)                       char(15) int static options(constant) init (
 82                                              "after",       /* Name of entry points supported herein.         */
 83                                              "before",
 84                                              "bool",
 85                                              "collate",
 86                                              "collate9",
 87                                              "copy_characters",
 88                                              "decat",
 89                                              "high",
 90                                              "high9",
 91                                              "index",
 92                                              "length",
 93                                              "low",
 94                                              "lower_case",
 95                                              "ltrim",
 96                                              "reverse",
 97                                              "reverse_after",
 98                                              "reverse_before",
 99                                              "reverse_decat",
100                                              "reverse_index",
101                                              "reverse_search",
102                                              "reverse_substr",
103                                              "reverse_verify",
104                                              "rtrim",
105                                              "search",
106                                              "substr",
107                                              "translate",
108                                              "upper_case",
109                                              "verify"),
110           max_args (28)                 fixed bin int static options(constant) init (
111                                              2,   2,   3,   0,   0,   2,   3,   1,   1,   2,
112                                              1,   1, 999,   2,   1,   2,   2,   3,   2,   2,
113                                              3,   2,   2,   2,   3,   3, 999,   2),
114           min_args (28)                 fixed bin int static options(constant) init (
115                                              2, 2, 3, 0, 0, 2, 3, 1, 1, 2,
116                                              1, 1, 1, 1, 1, 2, 2, 3, 2, 2,
117                                              2, 2, 1, 2, 2, 2, 1, 2),
118           options (28)                  char(52) int static options(constant) init (
119                                              "source_string indexing_string",
120                                              "source_string indexing_string",
121                                              "bit_string bit_string 4_bit_string",
122                                              "",
123                                              "",
124                                              "string number_of_copies",
125                                              "source_string indexing_string 3_bit_string",
126                                              "number_of_copies",
127                                              "number_of_copies",
128                                              "source_string indexing_string",
129                                              "string",
130                                              "number_of_copies",
131                                              "strings",
132                                              "source_string search_string",
133                                              "string",
134                                              "source_string indexing_string",
135                                              "source_string indexing_string",
136                                              "source_string indexing_string 3_bit_string",
137                                              "source_string indexing_string",
138                                              "source_string search_string",
139                                              "string starting_index_number {length}",
140                                              "source_string verify_string",
141                                              "source_string search_string",
142                                              "source_string search_string",
143                                              "string starting_index_number {length}",
144                                              "string translate_to_string {translate_from_string}",
145                                              "strings",
146                                              "source_string verify_string"),
147           sys_info$max_seg_size         fixed bin(35) ext static;
148 
149       dcl TRUE                          bit (1) aligned internal static options (constant) init ("1"b),
150           FALSE                         bit (1) aligned internal static options (constant) init ("0"b);
151 ^L
152 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
153 
154 
155           e = 25;                                           /* substr                                         */
156           go to COMMON;
157 
158 
159 after:  af:         entry;
160 
161           e = 1;
162           go to COMMON;
163 
164 
165 before:  be:        entry;
166 
167           e = 2;
168           go to COMMON;
169 
170 
171 bool:     entry;
172 
173           e = 3;
174           go to COMMON;
175 
176 
177 collate:  entry;
178 
179           e = 4;
180           go to COMMON;
181 
182 
183 collate9: entry;
184 
185           e = 5;
186           go to COMMON;
187 
188 
189 copy_characters:  cpch:       entry;
190 
191           e = 6;
192           go to COMMON;
193 
194 
195 decat:    entry;
196 
197           e = 7;
198           go to COMMON;
199 
200 
201 high:     entry;
202 
203           e = 8;
204           go to COMMON;
205 
206 
207 high9:    entry;
208 
209           e = 9;
210           go to COMMON;
211 
212 
213 index:    entry;
214 
215           e = 10;
216           go to COMMON;
217 
218 
219 length:  ln:        entry;
220 
221           e = 11;
222           go to COMMON;
223 
224 
225 low:      entry;
226 
227           e = 12;
228           go to COMMON;
229 
230 
231 lower_case: lowercase:        entry;
232 
233           e = 13;
234           go to COMMON;
235 
236 
237 ltrim:    entry;
238 
239           e = 14;
240           go to COMMON;
241 
242 
243 reverse:  rv:       entry;
244 
245           e = 15;
246           go to COMMON;
247 
248 
249 reverse_after:  rvaf:         entry;
250 
251           e = 16;
252           go to COMMON;
253 
254 
255 reverse_before:  rvbe:        entry;
256 
257           e = 17;
258           go to COMMON;
259 
260 
261 reverse_decat:  rvdecat:      entry;
262 
263           e = 18;
264           go to COMMON;
265 
266 
267 reverse_index:  rvindex:      entry;
268 
269           e = 19;
270           go to COMMON;
271 
272 
273 reverse_search:  rvsrh:       entry;
274 
275           e = 20;
276           go to COMMON;
277 
278 reverse_substr:  rvsubstr:    entry;
279 
280           e = 21;
281           go to COMMON;
282 
283 reverse_verify:  rvverify:    entry;
284 
285           e = 22;
286           go to COMMON;
287 
288 
289 rtrim:    entry;
290 
291           e = 23;
292           go to COMMON;
293 
294 
295 search:  srh:       entry;
296 
297           e = 24;
298           go to COMMON;
299 
300 
301 translate:          entry;
302 
303           e = 26;
304           go to COMMON;
305 
306 
307 upper_case: uppercase:        entry;
308 
309           e = 27;
310           go to COMMON;
311 
312 
313 verify:   entry;
314 
315           e = 28;
316           go to COMMON;
317 
318 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
319 ^L
320 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
321 COMMON:   call cu_$af_return_arg (Nargs, Pret, Lret, code); /* get arg count, see how called, get ret val.    */
322           if code = 0 then do;                              /* called as an active function.                  */
323                error = active_fnc_err_;
324                arg_ptr = cu_$af_arg_ptr;
325                Scommand = FALSE;
326                end;
327           else do;                                          /* called as a command.                           */
328                error = com_err_;
329                arg_ptr = cu_$arg_ptr;
330                Scommand = TRUE;
331                Nargs = cu_$arg_count();
332                Pret = null;
333                on cleanup call janitor();
334                call get_temp_segment_ (ep(e), Pret, code);
335                if code ^= 0 then go to NO_TEMP_SEG;
336                Lret = (sys_info$max_seg_size - 1) * 4;
337                end;
338 ^L
339           if Nargs < min_args(e) then                       /* too few input arguments.                       */
340                go to wnoa;
341           if Nargs > max_args(e) then                       /* too many input arguments.                      */
342                go to wnoa;
343           do i = 1 to min (Nargs, 3);                       /* address input arguments.                       */
344                call arg_ptr (i, Parg(i), Larg(i), code);
345                end;
346 
347           ret = "";                                         /* clear return arg.                              */
348           go to do(e);                                      /* process according to input requirements.       */
349 ^L
350 do( 1):                                                     /* after.                                         */
351           ret = double_quotes(after(arg1,arg2));
352           go to return;
353 
354 do( 2):                                                     /* before                                         */
355           ret = double_quotes(before (arg1, arg2));
356           go to return;
357 
358 do( 3):                                                     /* bool                                           */
359           i = verify(arg1, "01");
360           if i > 0 then do;
361                i = 1;
362                go to bad_conversion;
363                end;
364           i = verify(arg2, "01");
365           if i > 0 then do;
366                i = 2;
367                go to bad_conversion;
368                end;
369           if Larg(3) ^= 4 then do;
370                i = 4;
371                go to bad_bit_string;
372                end;
373           char4 = arg3;
374           i = verify(char4, "01");
375           if i > 0 then do;
376                i = 3;
377                go to bad_conversion;
378                end;
379           bit4 = bit(char4, 4);
380           ret = character(bool(bit(arg1), bit(arg2), bit4));
381           go to return;
382 
383 do( 4):                                                     /* collate                                        */
384           if Scommand then                                  /* when invoked as a command, print collating seq */
385                ret = collate();
386           else do;
387                ret = """";
388                ret = ret || substr (collate(),1,35);
389                ret = ret || substr (collate(),35);          /* double the quote in the quoted string.         */
390                ret = ret || """";
391                end;
392           go to return;
393 
394 do( 5):                                                     /* collate9                                       */
395           if Scommand then
396                ret = collate9();
397           else do;
398                ret = """";
399                ret = ret || substr (collate(),1,35);
400                ret = ret || substr (collate9(),35);
401                ret = ret || """";
402                end;
403           go to return;
404 ^L
405 do( 6):                                                     /* copy                                           */
406           on conversion begin;
407                i = 2;
408                go to bad_conversion;
409                end;
410           n = convert(n, arg2);
411           revert conversion;
412           if n < 0 then do;
413                i = 2;
414                go to nonnegative_arg;
415                end;
416           else if n = 0 then;
417           else
418                ret = double_quotes(copy (arg1, n));
419           go to return;
420 
421 do( 7):                                                     /* decat                                          */
422           if Larg(3) ^= 3 then do;
423                i = 3;
424                go to bad_bit_string;
425                end;
426           char3 = arg3;
427           i = verify (char3, "01");
428           if i > 0 then do;
429                i = 3;
430                go to bad_conversion;
431                end;
432           bit3 = bit(char3, 3);
433           ret = double_quotes(decat (arg1, arg2, bit3));
434           go to return;
435 
436 do( 8):                                                     /* high                                           */
437 do( 9):                                                     /* high9                                          */
438 do(12):                                                     /* low                                            */
439           on conversion begin;
440                i = 1;
441                go to bad_conversion;
442                end;
443           n = convert(n, arg1);
444           revert conversion;
445           if n < 0 then do;
446                i = 1;
447                go to nonnegative_arg;
448                end;
449           else if n = 0 then
450                go to return;
451           else go to do_hl(e);
452 do_hl(8):
453           ret = high(n);
454           go to return;
455 do_hl(9):
456           ret = high9(n);
457           go to return;
458 do_hl(12):
459           ret = low(n);
460           go to return;
461 ^L
462 do(10):                                                     /* index                                          */
463           i = index (arg1, arg2);
464 ret_num:  Npic = i;
465           ret = ltrim(Npic);
466           go to return;
467 
468 do(11):                                                     /* length                                         */
469           i = Larg(1);
470           go to ret_num;
471 
472 do(13):                                                     /* lower_case                                     */
473           do i = 1 to Nargs;
474                call arg_ptr (i, Parg (1), Larg (1), 0);
475                if ret ^= "" then ret = ret || " ";
476                ret = ret || double_quotes (translate (arg1, LOWERCASE, UPPERCASE));
477           end;
478           go to return;
479 
480 do(14):                                                     /* ltrim                                          */
481           if Nargs = 2 then
482                ret = double_quotes(ltrim(arg1, arg2));
483           else ret = double_quotes(ltrim(arg1));
484           go to return;
485 
486 do(15):                                                     /* reverse                                        */
487           if Larg(1) <= 0 then;
488           else
489                ret = double_quotes(reverse (arg1));
490           go to return;
491 
492 do(16):                                                     /* reverse after                                  */
493           if index(arg1, arg2) > 0 then
494                ret = double_quotes(reverse(before(reverse(arg1), reverse(arg2))));
495           else ret = "";
496           go to return;
497 
498 do(17):                                                     /* reverse before                                 */
499           if index(arg1, arg2) > 0 then
500                ret = double_quotes(reverse(after(reverse(arg1), reverse(arg2))));
501           else ret = double_quotes(arg1);
502           go to return;
503 
504 do(18):                                                     /* reverse decat                                  */
505           if Larg(3) ^= 3 then do;
506                i = 3;
507                go to bad_bit_string;
508                end;
509           char3 = arg3;
510           i = verify (char3, "01");
511           if i > 0 then do;
512                i = 3;
513                go to bad_conversion;
514                end;
515           bit3 = bit(char3, 3);
516           if index(arg1, arg2) > 0 then
517                ret = double_quotes(reverse(decat(reverse(arg1), reverse(arg2), reverse(bit3))));
518           else ret = double_quotes(decat(arg1, arg2, bit3));
519           go to return;
520 ^L
521 do(19):                                                     /* reverse_index                                  */
522           i = index (reverse(arg1), reverse(arg2));
523           if i > 0 then
524                i = Larg(1) - i + 2 - Larg(2);
525           go to ret_num;
526 
527 do(20):                                                     /* reverse_search                                 */
528           i = search (reverse(arg1), arg2);
529           if i > 0 then
530                i = Larg(1) - i + 1;
531           go to ret_num;
532 
533 do(21):                                                     /* reverse_substr                                 */
534           on conversion begin;
535                i = 2;
536                go to bad_conversion;
537                end;
538           i = convert(i, arg2);
539           revert conversion;
540           if Nargs = 3 then do;
541                on conversion begin;
542                     i = 3;
543                     go to bad_conversion;
544                     end;
545                j = convert(j, arg3);
546                revert conversion;
547                end;
548           else
549                j = Larg(1);
550           if i <= 0 then do;
551                i = 2;
552                go to positive_arg;
553                end;
554           else if i > Larg(1) then;
555           else if j < 0 then do;
556                i = 3;
557                go to nonnegative_arg;
558                end;
559           else if j = 0 then;
560           else do;
561                if i+j-1 > Larg(1) then
562                     j = Larg(1) - i + 1;
563                ret = double_quotes(reverse (substr (reverse (arg1), i, j)));
564                end;
565           go to return;
566 
567 do(22):                                                     /* reverse_verify                                 */
568           i = verify (reverse(arg1), arg2);
569           if i > 0 then
570                i = Larg(1) - i + 1;
571           go to ret_num;
572 
573 do(23):                                                     /* rtrim                                          */
574           if Nargs = 2 then
575                ret = double_quotes(rtrim(arg1, arg2));
576           else ret = double_quotes(rtrim(arg1));
577           go to return;
578 
579 do(24):                                                     /* search                                         */
580           i = search (arg1, arg2);
581           go to ret_num;
582 ^L
583 do(25):                                                     /* substr                                         */
584           on conversion begin;
585                i = 2;
586                go to bad_conversion;
587                end;
588           i = convert(i, arg2);
589           revert conversion;
590           if Nargs = 3 then do;
591                on conversion begin;
592                     i = 3;
593                     go to bad_conversion;
594                     end;
595                j = convert(j, arg3);
596                revert conversion;
597                end;
598           else
599                j = Larg(1);
600           if i <= 0 then do;
601                i = 2;
602                go to positive_arg;
603                end;
604           else if i > Larg(1) then;
605           else if j < 0 then do;
606                i = 3;
607                go to nonnegative_arg;
608                end;
609           else if j = 0 then;
610           else do;
611                if i+j-1 > Larg(1) then
612                     j = Larg(1) - i + 1;
613                ret = double_quotes(substr (arg1, i, j));
614                end;
615           go to return;
616 
617 do(26):                                                     /* translate                                      */
618           if Nargs = 2 then
619                ret = double_quotes(translate (arg1, arg2));
620           else
621                ret = double_quotes(translate (arg1, arg2, arg3));
622           go to return;
623 ^L
624 do(27):                                                     /* upper_case                                     */
625           args_sw, leading_sw = "0"b;
626           do i = 1 to Nargs;
627                call arg_ptr (i, Parg (1), Larg (1), 0);
628                if ^args_sw & substr (arg1, 1, 1) = "-" then
629                     if arg1 = "-leading" then leading_sw = "1"b;
630                     else if arg1 = "-arguments" | arg1 = "-ag" then args_sw = "1"b;
631                     else do;
632                          call error (error_table_$badopt, "uppercase", "^a", arg1);
633                          return;
634                     end;
635                else do;
636                     args_sw = "1"b;
637                     if leading_sw then do;
638                          if ret ^= "" then ret = ret || " ";
639                          ret = ret || double_quotes (arg1);
640                     end;
641                     else do;
642                          if ret ^= "" then ret = ret || " ";
643                          ret = ret || double_quotes (translate (arg1, UPPERCASE, LOWERCASE));
644                     end;
645                end;
646           end;
647 
648           if leading_sw then do;
649                substr (ret, 1, 1) = translate (substr (ret, 1, 1), UPPERCASE, LOWERCASE);
650                do i = 2 to length (ret);
651                     if index (LOWERCASE, substr (ret, i, 1)) ^= 0 then
652                          if index (UPPERCASE || LOWERCASE || "'-", substr (ret, i - 1, 1)) = 0 then
653                                                             /* lowercase alpha preceded by nonalpha -> upper */
654                               substr (ret, i, 1) = translate (substr (ret, i, 1), UPPERCASE, LOWERCASE);
655                end;
656           end;
657           go to return;
658 
659 do(28):                                                     /* verify                                         */
660           i = verify (arg1, arg2);
661           go to ret_num;
662 
663 return:   if Scommand then do;
664                call ioa_ (UP_A, ret);
665                call release_temp_segment_ (ep(e), Pret, code);
666                end;
667           return;
668 ^L
669 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
670 
671 
672 positive_arg:
673           j = 1;
674           go to bad_arg;
675 nonnegative_arg:
676           j = 2;
677 bad_arg:  Parg(1) = Parg(i);
678           Larg(1) = Larg(i);
679           call error (error_table_$bad_arg, ep(e), " ^a
680   Argument ^d must be a ^[positive^;nonnegative^] integer.", arg1, i, j);
681           call janitor();
682           return;
683 
684 wnoa:     call error (error_table_$wrong_no_of_args, ep(e), "
685   Usage:  ^[[^]^a ^a^[]^]", ^Scommand, ep(e), options(e), ^Scommand);
686           call janitor();
687           return;
688 
689 NO_TEMP_SEG:
690           call error (code, ep(e), "^/While obtaining a temporary segment.");
691           return;
692 
693 bad_bit_string:
694           call error (error_table_$bad_arg, ep(e), " ^a
695   Third argument must be a bit string of length ^d.
696   Usage:  ^[[^]^a ^a^[]^]", arg3, i, ^Scommand, ep(e), options(e), ^Scommand);
697           call janitor();
698           return;
699 
700 bad_conversion:
701           Parg(1) = Parg(i);
702           Larg(1) = Larg(i);
703           call error (error_table_$bad_conversion, ep(e), " ^a
704   Usage:  ^[[^]^a ^a^[]^]", arg1, ^Scommand,ep(e), options(e), ^Scommand);
705           call janitor();
706           return;
707 
708 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
709 ^L
710 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
711 
712 
713 double_quotes:      procedure (string) returns (char(*) varying);
714                                                             /* internal procedure to double all quotes in     */
715                                                             /* a string.                                      */
716 
717      dcl  string                        char(*);
718 
719      dcl (i, j)                         fixed bin;
720 
721 
722      dcl  copied_string                 char(length(string)*2+2) varying;
723 
724      dcl  string_begin                  char(i-1) based (addr(string_array(j))),
725           string_end                    char(length(string)-(j-1)) based(addr(string_array(j))),
726           string_array (length(string)) char(1) based (addr(string));
727 
728           if Scommand then return (string);
729           i = search(string,"""");
730           if i = 0 then return("""" || string || """");
731           j = 1;
732           copied_string = """";
733           do while (i > 0);
734                copied_string = copied_string || string_begin;
735                copied_string = copied_string || """""";
736                j = i+j;
737                i = search (string_end, """");
738                end;
739           copied_string = copied_string || string_end;
740           copied_string = copied_string || """";
741           return (copied_string);
742 
743 
744           end double_quotes;
745 
746 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
747 
748 
749 janitor: procedure;
750 
751           if  Scommand  &  Pret ^= null  then
752                call release_temp_segment_ (ep(e), Pret, code);
753 
754           end janitor;
755 
756 /*  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  **  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  *  */
757 
758 
759           end substr;