1 /****^  ***********************************************************
   2         *                                                         *
   3         * Copyright, (C) Honeywell Bull Inc., 1988                *
   4         *                                                         *
   5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   6         *                                                         *
   7         *********************************************************** */
   8 
   9 
  10 /****^  HISTORY COMMENTS:
  11   1) change(88-08-03,RWaters), approve(88-08-03,MCR7950), audit(88-09-29,Huen),
  12      install(88-10-07,MR12.2-1146):
  13      Bug fixes for MR12.2.
  14                                                    END HISTORY COMMENTS */
  15 
  16 
  17 /**** format: ind3,ll80,initcol6,indattr,^inddcls,dclind4,idind16            */
  18 /**** format: struclvlind2,^ifthenstmt,^ifthendo,^ifthen,^indnoniterdo       */
  19 /**** format: ^inditerdo,^indnoniterend,^indthenelse,case,^indproc,^indend   */
  20 /**** format: ^delnl,^insnl,comcol41,^indcom,^indblkcom,linecom,^indcomtxt   */
  21 
  22 /*                                                                           */
  23 /*   _|_              |                                                      */
  24 /*    |      _      _ |           _      _                                   */
  25 /*    |     / \    / \|  |/|/|   / \|  |/ \                                  */
  26 /*    |    (__/   (   |  | | |  (   |  |                                     */
  27 /*    \_    \_/    \_/|  | | |   \_/|  |                                     */
  28 /*                                  |         -----                          */
  29 /*                              \__/                                         */
  30 
  31 /* UPDATE HISTORY (finally)                                                  */
  32 /* EL#   date       TR        comments                                       */
  33 /* 139 84-10-09 phx17096 "q" complains about buffer even though its deleted  */
  34 /* 140 84-10-09 phx17209 "x" on windowed buffer not show windowed size       */
  35 /* 158 84-10-10 phx17290 "ted -restart" with 1 active environment will get   */
  36 /*                  the user into a confusing dialogue.                      */
  37 /* 152 84-10-11 phx17594  OOB fault on empty buffer (after [buffer X])       */
  38 /* 163 88-07-08 changed pic6 to be picture 7 to avoid size condition in      */
  39 /*                       buffers that exceed 99999 lines.                    */
  40 /* 201 88-07-08 phx20688 fix message about archive component.                */
  41 /* NNN 88-19-07 flag the buffer as modified when ted_buffer get called as    */
  42 /*                       an active function                                  */
  43 
  44 tedmgr_:                                /* dump current database             */
  45    proc;
  46 
  47       dbase_p = envir.bwd;              /* pick up latest environment        */
  48       call ioa_$ioa_switch (db_output,
  49          "ptr(^d)=^p  ""^a""", env_ct, dbase_p,
  50          dbase.dir_db);
  51       if (dbase_p = null ())
  52       then return;
  53       call tedshow_ (dbase_p, "base");
  54       return;
  55 
  56 list:                                   /* list all active pointers          */
  57    entry;
  58 dcl ptr_2           (2) ptr based;
  59       tp = envir.bwd;
  60       do while (tp ^= null ());
  61          call ioa_$ioa_switch (db_output,
  62             "  @^p^-`^a'^( ^p^)", tp, tp -> dbase.recurs,
  63             tp -> dbase.bwd, addr (tp -> dbase.reset) -> ptr_2);
  64          tp = tp -> dbase.bwd;
  65       end;
  66       call ioa_$ioa_switch (db_output, "    EOL");
  67       return;%skip(5);
  68 dcl 1 DATABASE      based (dbase_p),
  69       2 zzzzzz      like dbase,
  70       2 cb          (0:DATABASE.bufnum) like b;
  71 
  72 dcl 1 entries       (e_c) aligned based (e_p),
  73       2 type        bit (2) unal,
  74       2 nnames      fixed bin (15) unal,
  75       2 nindex      fixed bin (17) unal;
  76 dcl names           (3) char (32) based (n_p);
  77 
  78 dcl NL              char (1) int static options (constant) init ("
  79 ");
  80 dcl area_p          ptr;
  81 dcl arg             char (arg_l) based (arg_p);
  82 dcl arg_bufs        fixed bin;
  83 dcl arg_l           fixed bin (21);
  84 dcl arg_p           ptr;
  85 dcl cleanup         condition;
  86 dcl code            fixed bin (35);
  87 dcl db_dir          char (168) var;
  88 dcl DD              pic "99";
  89 dcl (
  90     error_table_$action_not_performed,
  91     error_table_$dirseg,
  92     error_table_$invalid_lock_reset,
  93     error_table_$locked_by_this_process,
  94     error_table_$namedup,
  95     error_table_$noentry,
  96     error_table_$no_component,
  97     error_table_$unimplemented_version,
  98     error_table_$zero_length_seg
  99    )                fixed bin (35) ext static;
 100 dcl e_c             fixed bin;
 101 dcl e_ca            fixed bin;
 102 dcl e_p             ptr;
 103 dcl func            fixed bin;
 104 dcl i               fixed bin (21);
 105 dcl ii              fixed bin (21);
 106 dcl j               fixed bin (21);
 107 dcl lockid          bit (36) int static init ("0"b);
 108 dcl n_p             ptr;
 109 dcl pdir            char (32)int static init ("");
 110 dcl pic3            pic "999";
 111 dcl reply           char (32);
 112 dcl rqid            char (19);
 113 dcl startup         fixed bin (71);
 114 dcl status_only     bit (1);
 115 dcl the_name        char (32);
 116 dcl tp              ptr;
 117 dcl used            fixed bin (21);
 118 
 119 /* ------------------------- EXTERNAL PROCEDURES --------------------------- */
 120 
 121 dcl com_err_        entry options (variable);
 122 dcl cu_$arg_ptr     entry (fixed bin, ptr, fixed bin (21), fixed bin (35));
 123 dcl cu_$arg_ptr_rel entry (fixed bin, ptr, fixed bin (21), fixed bin (35), ptr);
 124 dcl cv_dec_check_   entry (char (*), fixed bin (35)) returns (fixed bin (35));
 125 dcl delete_$ptr     entry (ptr, bit (6), char (*), fixed bin (35));
 126 dcl delete_$path    entry (char (*), char (*), bit (6), char (*),
 127                     fixed bin (35));
 128 dcl get_default_wdir_ entry returns (char (168));
 129 dcl get_lock_id_    entry returns (bit (36));
 130 dcl get_system_free_area_ entry returns (ptr);
 131 dcl get_temp_segment_ entry (char (*), ptr, fixed bin (35));
 132 dcl hcs_$append_link entry (char (*), char (*), char (*), fixed bin (35));
 133 dcl hcs_$fs_get_path_name entry (ptr, char (*), fixed bin (21), char (*),
 134                     fixed bin (35));
 135 dcl hcs_$initiate   entry (char (*), char (*), char (*), fixed bin (1),
 136                     fixed bin (2), ptr, fixed bin (35));
 137 dcl hcs_$make_seg   entry (char (*), char (*), char (*), fixed bin (5), ptr,
 138                     fixed bin (35));
 139 dcl hcs_$set_bc_seg entry (ptr, fixed bin (21), fixed bin (35));
 140 dcl hcs_$star_      entry (char (*), char (*), fixed bin (2), ptr, fixed bin,
 141                     ptr, ptr, fixed bin (35));
 142 dcl hcs_$terminate_noname entry (ptr, fixed bin (35));
 143 dcl hcs_$truncate_seg entry (ptr, fixed bin (18), fixed bin (35));
 144 dcl get_pdir_       entry () returns (char (168));
 145 dcl ioa_            entry options (variable);
 146 dcl ioa_$nnl        entry () options (variable);
 147 dcl ioa_$ioa_switch entry () options (variable);
 148 dcl iox_$error_output ptr ext static;
 149 dcl iox_$get_line   entry (ptr, ptr, fixed bin (21), fixed bin (21),
 150                     fixed bin (35));
 151 dcl iox_$user_input ptr ext static;
 152 dcl release_temp_segment_ entry (char (*), ptr, fixed bin (35));
 153 dcl set_lock_$lock  entry (bit (36), fixed bin, fixed bin (35));
 154 dcl request_id_     entry (fixed bin (71)) returns (char (19));
 155 dcl user_info_      entry options (variable);
 156 
 157 dcl env_ct          fixed bin int static init (0);
 158 dcl 1 envir         int static,
 159       2 (fwd, bwd)  ptr init (null ());
 160 
 161 dcl (
 162     clock, convert, ltrim, low, max, ptr, rel,
 163     rtrim, string, unspec
 164     )               builtin;
 165 
 166 /**** <<<<----- dcl_tedinit_.incl.pl1 tedinit_                               */
 167 tedinit_:                               /* create a ted environment          */
 168    entry (ted_data_p, adb_p, acode);
 169 dcl (
 170     ted_data_p      ptr,                /* -> ted_ input structure           */
 171     adb_p           ptr,                /* -> dbase                    (OUT) */
 172     acode           fixed bin (35)      /* status code                       */
 173     )               parm;               /* ----->>>>                         */
 174 
 175       if (pdir = "")
 176       then pdir = get_pdir_();
 177       if ted_data.version = 1000        /* handle old version                */
 178       then do;
 179          if (ted_data.ted_mode = RESTART) | (ted_data.ted_mode = SAFE)
 180          then db_dir = rtrim (get_default_wdir_ ());
 181          else db_dir = "";
 182       end;
 183       else db_dir = rtrim (ted_data.temp_dir);
 184       status_only = "0"b;
 185       the_name = ted_data.tedname;
 186       goto somehow;
 187 
 188 /**** <<<<----- dcl_tedstatus_.incl.pl1 tedstatus_                           */
 189 tedstatus_:                             /* display saved environments        */
 190    entry (tempdir, acode);
 191 dcl (
 192     tempdir         char (*)            /* name of temp dir                  */
 193 /****acode          fixed bin (35)      /* status code                       */
 194     )               parm;               /* ----->>>>                         */
 195 
 196 dcl i21             fixed bin (21);
 197 
 198       db_dir = tempdir;
 199       status_only = "1"b;
 200       the_name = "ted";
 201       goto status_1;
 202 
 203 nil_action:
 204       acode = error_table_$action_not_performed;
 205 abort_print:
 206       call com_err_ (acode, the_name, "^a^/^-abort[^a]", msg,
 207          convert (DD, env_ct));
 208 abort_no_print:
 209       goto get_out;
 210 somehow:
 211       acode = 1;
 212 
 213       if (env_ct >= 14) then do;
 214          msg = "Recursion exceeds depth of 14";
 215          goto nil_action;
 216       end;
 217 
 218       startup = clock ();
 219       if (lockid = "0"b)
 220       then lockid = get_lock_id_ ();
 221       e_p, n_p, dbase_p = null;
 222       e_c = 0;
 223       on condition (cleanup) begin;
 224             if (dbase_p ^= null ())
 225             then call tedcleanup_ (dbase_p);
 226          end;
 227       if (ted_data.ted_mode = RESTART)
 228       then do;
 229 status_1:
 230          area_p = get_system_free_area_ ();
 231          call hcs_$star_ ((db_dir), db_select, 3, area_p, e_c, e_p, n_p,
 232             acode);
 233          if (e_c = 0)
 234          then do;
 235 no_envir:
 236             msg = "No environment exists";
 237             if status_only
 238             then do;
 239                call ioa_ (msg);
 240                return;
 241             end;
 242             goto nil_action;
 243          end;
 244          begin;
 245 dcl ps              (e_c) ptr;
 246             e_ca = e_c;
 247             do i = 1 to e_c;
 248                call hcs_$initiate ((db_dir), names (entries (i).nindex),
 249                   "", 0, 1, ps (i), acode);
 250                if (ps (i) = null ())
 251                then do;
 252                   e_ca = e_ca - 1;
 253                   if (acode = error_table_$dirseg)
 254                   then do;
 255                   end;
 256                   else if (acode = error_table_$noentry)
 257                   then do;
 258 /**** The only way I know that this can happen is when a -temp_dir was       */
 259 /****  specified (thus a link was created) and now the destination of that   */
 260 /****  link does not exist.                                                  */
 261                      call delete_$path ((db_dir), names (entries (i).nindex),
 262                         "100010"b, the_name, (code));
 263                                         /* try to unlink                     */
 264 
 265                   end;
 266                   else call com_err_ (acode, the_name, "^a>^a", db_dir,
 267                      names (entries (i).nindex));
 268                end;
 269                else do;
 270                   if (ps (i) -> dbase.version ^= dbase_vers_3)
 271                   then do;
 272                      call com_err_ (error_table_$unimplemented_version,
 273                         the_name, "^a>^a", db_dir,
 274                         names (entries (i).nindex));
 275                      call term;
 276                   end;
 277                   else if (e_c > 1) | status_only
 278                   then do;
 279                   end;
 280                end;
 281             end;
 282             if (e_ca < 1)
 283             then goto no_envir;
 284             if (e_ca > 1) & ^status_only
 285             then call ioa_ ("More than 1 environment exists.");
 286             force = ""b;                                              /* #158*/
 287 displ_1:
 288             if (e_ca > 1) | status_only
 289             | force                                                   /* #158*/
 290             then call ioa_ (" #     Started, by whom, as what");
 291 dcl (shown, activ)  fixed bin;
 292 dcl mylock          fixed bin;                                        /* #158*/
 293 dcl force           bit (1);                                          /* #158*/
 294 dcl b1              bit (1);
 295 
 296             shown = 0;
 297 displ:
 298             activ = 0;
 299             mylock = 0;
 300             do i = 1 to e_c while ((e_ca > 1) | status_only | force); /* #158*/
 301                if ps (i) ^= null ()
 302                then do;
 303                   dbase_p = ps (i);
 304                   if db_util
 305                   then call ioa_$ioa_switch (db_output,
 306                      "B ^p -> ^w [^i]", ps (i),
 307                           dbase.lock, dbase.recurs);
 308                   if (dbase.recurs = 0)
 309                   then dbase.lock = "0"b;
 310                   else if (dbase.lock = "0"b)
 311                   then dbase.recurs = 0;
 312                   else do;
 313                      call set_lock_$lock (dbase.lock,
 314                         0, acode);
 315                      if db_util
 316                   then call ioa_$ioa_switch (db_output,
 317                         "A ^p -> ^w [^i]", ps (i),
 318                           dbase.lock, dbase.recurs);
 319                      if (acode = error_table_$invalid_lock_reset)
 320                      then do;
 321                         dbase.lock = "0"b;
 322                         dbase.recurs = 0;
 323                      end;
 324                      if (acode = error_table_$locked_by_this_process)
 325                      then mylock = mylock + 1;                        /* #158*/
 326                   end;
 327                   b1 = (dbase.recurs ^= 0);
 328                   if b1
 329                   then activ = activ + 1;
 330                   shown = shown + 1;
 331                   call ioa_ (
 332                      "^2i^[*^; ^] ^a   ^a.^a (^a[^i])",
 333                      i, b1, date_time_$format ("date_time", dbase.time,"",""),
 334                      dbase.person, dbase.project,
 335                      dbase.tedname, dbase.recurs);
 336                   if dbase.remote_sw
 337                   then call ioa_ ("     @ ^a", dbase.dir_db);
 338                   if (length (dbase.comment) > 0)
 339                   then call ioa_ ("^-comment=^a",
 340                           dbase.comment);
 341                end;
 342             end;
 343             if (activ > 0)
 344             then call ioa_ ("(*=now active)");
 345             if status_only
 346             then goto freum2;
 347             if (shown = 0) & ^force                         /* BEGIN     #158*/
 348             then do;
 349                force = "1"b;
 350                shown = 0;
 351                goto displ_1;
 352             end;
 353             if (activ = shown)
 354             then do;
 355                if (shown > 1)
 356                then do;
 357                   call ioa_ ("
 358 All saved ted environments found are active.");
 359                   if (mylock > 0)
 360                   then call ioa_ (
 361 "  Use ""pi"" or ""ted -reset"" to return to the latest one you have active.");
 362                   if (mylock > 1)
 363                   then call ioa_ (
 364 "  Use ""ted -reset 1"" to return to the first one you have active,
 365   discarding environment^[ 2^;s 2 thru ^i.^]",
 366                   (mylock=2), mylock);
 367                end;
 368                else call ioa_ ("
 369 The only saved ted environment found is active.^[
 370   Use ""pi"" or ""ted -reset"" to return to it.^]",
 371                   (mylock>0));                              /* END       #158*/
 372                goto freum;
 373             end;
 374             if (e_ca = 1) & (activ <= shown)
 375             then i = 1;
 376             else do;
 377                i = 0;
 378                call ioa_ ("Type the number of the one you want or ""?"".");
 379             end;
 380             do while (i = 0);
 381 getline:
 382                call iox_$get_line (iox_$user_input, addr (reply),
 383                   length (reply), i21, acode);
 384                if (substr (reply, 1, 1) = "q")
 385                then goto freum;
 386                if (substr (reply, 1, 1) = "l")
 387                then goto displ;
 388                if (substr (reply, 1, 2) = "??")
 389                then call ioa_ ("  sN^-dump of environment N");
 390                if (substr (reply, 1, 1) = "?")
 391                then do;
 392                   call ioa_ ("  dN^-delete environment N");
 393                   call ioa_ ("  xN^-list buffers in environment N");
 394                   call ioa_ ("  l^-list available environments");
 395                   call ioa_ ("  q^-quit");
 396                   goto getline;
 397                end;
 398                if (substr (reply, 1, 1) = "x")
 399                then do;
 400                   ii = 2;
 401                   func = 1;
 402                end;
 403                else if (substr (reply, 1, 1) = "d")
 404                then do;
 405                   ii = 2;
 406                   func = 2;
 407                end;
 408                else if (substr (reply, 1, 1) = "s")
 409                then do;
 410                   ii = 2;
 411                   func = 3;
 412                end;
 413                else do;
 414                   ii = 1;
 415                   func = 4;
 416                end;
 417                i = cv_dec_check_ (substr (reply, ii, i21 - ii), acode);
 418                if (acode ^= 0)
 419                   | (i < 1)
 420                   | (i > e_c)
 421                then do;
 422                   call ioa_ ("Please give a number in range 1-^i.",
 423                      e_c);
 424                   i = 0;
 425                   goto getline;
 426                end;
 427                if (ps (i) = null ())
 428                then do;
 429                   call ioa_ ("Environment ^i is not available.", i);
 430                   i = 0;
 431                   goto getline;
 432                end;
 433                goto rsfunc (func);
 434 rsfunc (1):                             /* function "x"                      */
 435                call tedlist_buffers_ (ps (i), "", "0"b, "0"b);
 436                goto getline;
 437 rsfunc (2):                             /* function "d"                      */
 438                if (ps (i) -> dbase.lock ^= "0"b)
 439                then do;
 440                   call ioa_ ("
 441 Environment ^i is currently active, delete not done.", i);
 442                   goto getline;
 443                end;
 444                                         /*-*/
 445                call tedcleanup_ (ps (i));
 446                ps (i) = null ();
 447                e_ca = e_ca - 1;
 448                if (e_ca < 1)
 449                then goto no_envir;
 450                goto getline;
 451 rsfunc (3):                             /* function "s"                      */
 452                dbase_p = ps (i);
 453                call tedshow_ (dbase_p, "base");
 454                goto getline; %skip (4);
 455 term: proc;
 456       call hcs_$terminate_noname (ps (i), 0);
 457       ps (i) = null ();
 458       e_ca = e_ca - 1;
 459    end;
 460 rsfunc (4):                             /* try starting up again             */
 461                if (ps (i) -> dbase.lock ^= "0"b)
 462                then do;
 463                   call ioa_ (
 464 "Environment ^i is currently active, restart not done.", i);
 465                   goto getline;
 466                end;
 467             end;
 468             dbase_p = ps (i);
 469             call set_lock_$lock (dbase.lock, 0, acode);
 470             if (acode = error_table_$invalid_lock_reset)
 471             then acode = 0;
 472             if (acode ^= 0)
 473             then do;
 474                call ioa_ ("The selected ted environment is already active.");
 475                goto getline;
 476             end;
 477             ps (i) = null ();
 478             if ""b
 479             then do;
 480 freum:
 481                acode = error_table_$action_not_performed;
 482                status_only = "1"b;
 483             end;
 484 freum2:
 485             free entries;
 486             free names;
 487             do i = 1 to e_c;
 488                if (ps (i) ^= null ())
 489                then call term;
 490             end;
 491          end;
 492 
 493          if status_only
 494          then return;
 495          call ioa_ ("Restarting session of ^a.",
 496             date_time_$format ("date_time", dbase.time,"",""));
 497          call restart;
 498       end;
 499       else do;                          /* starting from scratch             */
 500          if (db_dir ^= "")
 501          then do;
 502             call hcs_$star_ ((db_dir), db_select, 3, null (), e_c, e_p,
 503                n_p, code);
 504             if (e_c > 0)
 505             then call ioa_ ("^a: ^i environment^[s^] already saved.",
 506                     the_name, e_c, (e_c > 1));
 507          end;
 508          rqid = request_id_ (startup);
 509          dbase_p = null ();
 510          call get_base (adb_p, 0, "base    ", acode);
 511          dbase_p = adb_p;
 512          call start;
 513       end;
 514       env_ct = env_ct + 1;
 515       dbase.recurs = env_ct;
 516       dbase.lock = lockid;              /* show user is active               */
 517       dbase.bwd = envir.bwd;            /* link new one in to list           */
 518       envir.bwd = dbase_p;
 519       acode = 0;                        /* successful initialization         */
 520       adb_p = dbase_p;
 521 get_out:
 522       if db_util then call ioa_$ioa_switch (db_output,
 523          "dbase_p=^p[^i]", envir.bwd, env_ct);
 524       return;
 525 dcl db_select       char (26) int static options (constant) init (
 526                     "ted_.????????????.??????.X");
 527 /****               "ted_.820827000117.6795936.X"                            */
 528 %page;
 529 tedhold_:                               /* exit ted, keeping environment     */
 530    entry (adb_p);
 531       dbase_p = adb_p;
 532       cleaning = "0"b;
 533       goto hold_clean;
 534 
 535 dcl cleaning        bit (1);
 536 tedcleanup_:                            /* exit ted, destroying environment  */
 537    entry (adb_p);
 538       dbase_p = adb_p;
 539       if db_util then do;
 540          call ioa_$ioa_switch (db_output, "CLEANUP ^p", dbase_p);
 541          call tedshow_ (dbase_p, "base");
 542       end;
 543       cleaning = "1"b;
 544 hold_clean:
 545       if (dbase.recurs ^= 0)
 546       then do;
 547          if dbase_p ^= envir.bwd
 548          then signal condition (base_ne_envir); dcl base_ne_envir condition;
 549          envir.bwd = dbase.bwd;
 550          dbase.bwd = null;
 551          env_ct = env_ct - 1;
 552       end;
 553       the_name = dbase.tedname;
 554       dbase_lock = dbase.lock;
 555       dbase.lock = "0"b;                /* show not in service               */
 556 dcl dbase_lock      bit (36);
 557 dcl segid           char (32);
 558 
 559       if ^cleaning
 560       then do;
 561          do bp = addr (cb (0)), addr (cb (1));
 562             b.b_.l.re = b.b_.l.le - 1;  /* empty out b((request line))       */
 563             b.b_.r.le = b.b_.r.re + 1;  /* and b((ted))                      */
 564             b_s = low (b.maxl);
 565          end;
 566          if (dbase.seg_p (3) ^= null()) /* empty out call stack if there     */
 567          then call hcs_$truncate_seg (dbase.seg_p (3), 0, 0);
 568 
 569          do i = 0 to dbase.bufnum;
 570             bp = addr (cb (i));
 571             if (b.cur.sn > 0)           /* is there buffer space?            */
 572                & (i ^= 2)               /* and it's not the eval segment     */
 573                & ^b.pseudo              /* and its for real                  */
 574             then do;                    /* zero out the empty part           */
 575                substr (b_s, b.b_.l.re + 1,b.b_.r.le - b.b_.l.re - 1)
 576                   = low (b.b_.r.le - b.b_.l.re - 1);
 577             end;
 578          end;
 579       end;
 580       call delete_$path (pdir, "ted_." || dbase.rq_id, "100100"b,
 581          the_name, 0);                  /* cleanup possible fileout segment  */
 582       segid = "ted_.yymmddHHMMSS.UUUUUU.000";
 583       substr (segid, 6, 19) = dbase.rq_id;
 584       do i = dbase.seg_ct to 1 by -1;
 585          if (dbase.seg_p (i) ^= null ())
 586          then do;
 587             call wipeout (i);
 588          end;
 589       end;
 590       call wipeout (0);
 591       if db_util
 592       then call ioa_$ioa_switch (db_output,
 593          "^2d ^p", env_ct, envir.bwd);
 594       return; %skip (5);
 595 wipeout: proc (ndx);
 596 
 597 dcl ndx             fixed bin (21);
 598 
 599 dcl tp              ptr;
 600 
 601       tp = dbase.seg_p (i);
 602       if db_util
 603       then call ioa_$ioa_switch (db_output,
 604          "wipe: ^p^[ cleaning^]^[ active^]^[ base^]",
 605          tp, cleaning, (dbase_lock^="0"b), (ndx=0));
 606 
 607 /**** This statement is OK because the only way you will be cleaning up an   */
 608 /****  environment of temp segs is when the environment is active.           */
 609       if (dbase.dir_db = "")
 610       then call release_temp_segment_ (the_name, tp, code);
 611       else do;
 612 /**** If we're not cleaning out, then just tuck 'em in bed.                  */
 613          if ^cleaning
 614          then call hcs_$terminate_noname (tp, code);
 615          else do;
 616 /**** OK! We're throwing the stuff away.                                     */
 617             if (ndx = 0)
 618             then substr (segid, 26) = "X  ";
 619             else substr (segid, 26) = convert (pic3, i);
 620 /**** If the environment is active, get rid of them by pointer, otherwise we */
 621 /****  must do it by pathname.                                               */
 622             if (dbase_lock ^= "0"b)
 623             then call delete_$ptr (tp, "100100"b, the_name, code);
 624             else call delete_$path (dbase.dir_db, segid,
 625                "100100"b, the_name, code);
 626 /**** If -temp_dir was specified, a link was placed in the home dir so we    */
 627 /****  can find the database. When we clean up everything, this link is a    */
 628 /****  part of everything. We don't know or care if it is there...           */
 629             if (ndx = 0)
 630             then call delete_$path (get_default_wdir_ (), segid, "100010"b,
 631                     the_name, (code));  /* ...just get rid of it!            */
 632          end;
 633          if (code ^= 0)
 634          then call com_err_ (code, the_name);
 635       end;
 636    end wipeout; %page;
 637 dcl date_time_$format entry (char(*), fixed bin(71), char(*), char(*))
 638                     returns(char(250) var);
 639 buffer:                       /* return name of buffer segment     */
 640    entry;
 641 buf_comm:
 642       if (env_ct = 0)
 643       then do;
 644          call ioa_ ("Not in ted");
 645          return;
 646       end;
 647       call cu_$arg_ptr (1, arg_p, arg_l, code);
 648       if (code ^= 0) | (arg_l = 0)
 649       then do;
 650          call com_err_ (code, "ted_buffer", "Buffer name");
 651          return;
 652       end;
 653 
 654       dbase_p = envir.bwd;
 655       do j = 3 to dbase.bufnum;
 656          bp = addr (cb (j));
 657          if (b.name = arg)
 658          then do;
 659             if db_util
 660             then call tedshow_(bp,"bcb");
 661             if (b.cur.sn = -1)          /* is this a ^read file              */
 662             then do;
 663                if b.ck_ptr_sw
 664                then do;
 665                   if db_util then call ioa_$ioa_switch (db_output,
 666                      "ck_ptr");
 667                   call tedck_ptr_ (bp);
 668                end;
 669                dbase.not_read_ct = max (0, dbase.not_read_ct - 1);
 670             end;
 671             call tedcloseup_ (bp);      /* put into own segment              */
 672             if db_util
 673             then call tedshow_ (bp, "bcb");
 674             call hcs_$set_bc_seg (b.cur.sp, b.b_.l.re * 9, code);
 675             call hcs_$truncate_seg (b.cur.sp,
 676                divide (b.b_.l.re + 3, 4, 21, 0), code);
 677             if (dbase.dir_db = "")
 678             then do;
 679                call hcs_$fs_get_path_name (b.cur.sp, d_name, dl, e_name, 0);
 680                msg = substr (d_name, 1, dl);
 681                msg = msg || ">";
 682                msg = msg || rtrim (e_name);
 683             end;
 684             else do;
 685                msg = rtrim (dbase.dir_db);
 686                msg = msg || ">ted_.";
 687                msg = msg || dbase.rq_id;
 688                msg = msg || ".";
 689                msg = msg || convert (pic3, b.cur.sn);
 690             end;
 691             if db_util
 692             then call ioa_$ioa_switch (db_output,
 693                "val=`^va'", length (msg), msg);
 694             call cu_$af_arg_count (j, code);
 695             if (code ^= 0)
 696             then call ioa_ ("^a", msg);
 697             else do;
 698                b.get_bit_count = "1"b;
 699 /* RW 88 */
 700 /* e emacs [ted_buffer 0] should set the buffer as modified
 701  * possibly, it should also decriment the sequence number??
 702  * b.cur.sn--;
 703  */
 704                b.mod_sw = "1"b;                                       /* #NNN*/
 705                call cu_$af_return_arg (j + 1, af_ptr, af_len, code);
 706                af_val = msg;
 707             end;
 708             return;
 709          end;
 710       end;
 711       call com_err_ (0, "ted_buffer", "b(^a) not found.", arg);
 712       return;
 713 dcl d_name          char (168);
 714 dcl e_name          char (32);
 715 dcl dl              fixed bin (21);
 716 dcl cu_$af_arg_count entry (fixed bin (21), fixed bin (35));
 717 dcl cu_$af_return_arg entry (fixed bin (21), ptr, fixed bin (21),
 718                     fixed bin (35));
 719 dcl af_val          char (af_len) var based (af_ptr);
 720 dcl af_ptr          ptr;
 721 dcl af_len          fixed bin (21); %page;
 722 tedreset_:                              /* re-enter ted, simulating an error */
 723    entry;
 724 
 725       if (env_ct = 0)
 726       then do;
 727          call ioa_ ("Not in ted");
 728          return;
 729       end;
 730       call cu_$arg_ptr (1, arg_p, arg_l, code);
 731       if (code = 0)
 732       then do;
 733          if (verify (arg, "0123456789") = 0)
 734          then do;
 735             i = fixed (arg);
 736             if (i > env_ct)
 737             then do;
 738                call ioa_ ("ted[^a] not active", arg);
 739                return;
 740             end;
 741          end;
 742          else do;
 743             call ioa_ ("ted -reset: invalid argument");
 744             return;
 745          end;
 746       end;
 747       else i = env_ct;
 748       dbase_p = envir.bwd;
 749       j = env_ct;
 750       if db_util
 751       then call tedmgr_$list;
 752       do while (j > i);
 753          if db_util
 754          then call ioa_$nnl (" [^i] ^p ->", j, dbase_p);
 755          dbase_p = dbase.bwd;
 756          j = j - 1;
 757       end;
 758       if db_util
 759       then call ioa_$ioa_switch (db_output,
 760          " [^i] ^p", j, dbase_p);
 761       call ioa_$ioa_switch (iox_$error_output, "^a: reset[^i]",
 762          dbase.tedname, dbase.recurs);
 763       goto dbase.reset; %page;
 764 tedbreak_:                              /* set break mode and continue       */
 765    entry;
 766       if (env_ct = 0)
 767       then do;
 768          call ioa_ ("Not in ted");
 769          return;
 770       end;
 771       envir.bwd -> dbase.at_break = 1;
 772       call start$start;
 773 dcl start$start     entry;
 774       return; %page;
 775 /**** <<<<----- dcl_tedget_buffer_.incl.pl1 tedget_existing_buffer_          */
 776 tedget_existing_buffer_:                /* find a named buffer               */
 777    entry (adb_p, ain_p, ain_l, abp, a_msg);
 778 /****dcl (
 779 /****adb_p          ptr,                /* -> database                       */
 780 /****ain_p          ptr,                /* -> string containing buffer name  */
 781 /****ain_l          fixed bin (21),     /*   length of string           [IN] */
 782                                         /*   how much was used         [OUT] */
 783 /****abp            ptr                 /* buffer control block (OUT)        */
 784 /****a_msg          char (168)var       /* error message text                */
 785 /****)              parm;               /* ----->>>>                         */
 786 
 787       create = "0"b;
 788       goto common_get;
 789 
 790 /**** <<<<----- dcl_tedget_buffer_.incl.pl1 tedget_buffer_                   */
 791 tedget_buffer_:                         /* find (or create) a buffer         */
 792    entry (adb_p, ain_p, ain_l, abp, a_msg);
 793 dcl (
 794 /****adb_p          ptr,                /* -> database                       */
 795     ain_p           ptr,                /* -> string containing buffer name  */
 796     ain_l           fixed bin (21),     /*   length of string           [IN] */
 797                                         /*   how much was used         [OUT] */
 798     abp             ptr                 /* buffer control block (OUT)        */
 799 /****a_msg          char (168)var       /* error message text                */
 800     )               parm;               /* ----->>>>                         */
 801 
 802 dcl create          bit (1);
 803 
 804       create = "1"b;
 805 common_get:
 806       dbase_p = adb_p;
 807       if (dbase_p = null ())
 808       then dbase_p = envir.bwd;
 809       if (dbase_p = null ())
 810       then do;
 811          abp = null ();
 812                                         /* @@ */
 813          return;
 814       end;
 815 
 816 dcl hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (21),
 817                     fixed bin (35));
 818 find_buffer: begin;
 819                                         /* extract buffer name and find      */
 820                                         /*  (or create) buffer               */
 821 
 822 dcl next_in         fixed bin;          /* where at in address data          */
 823 dcl in_p            ptr;                /* -> address data                   */
 824 dcl in_l            fixed bin (21);     /*   length of it                    */
 825 dcl in_s            char (in_l) based (in_p); /* data as a string            */
 826 dcl in_c            (in_l) char (1) based (in_p); /* data as an array      */
 827 
 828 dcl i               fixed bin (21);
 829 dcl j               fixed bin (21);
 830 dcl l               fixed bin (21);
 831 dcl tch             char (1);
 832 dcl tnl             fixed bin (21);
 833 dcl tname           char (32);
 834 dcl MTi             fixed bin (21);
 835 dcl inext_in        fixed bin (21);
 836 /*                            dcl acode           fixed bin (35);            */
 837 
 838 make_buf: proc;
 839 
 840       if (MTi ^= 0)
 841       then do;
 842          bp = addr (cb (MTi));
 843          call re_alloc (bp, tname);
 844       end;
 845       else do;
 846          call allocate_cb (bp, tname);
 847       end;
 848    end make_buf;
 849 
 850          bp = null;                     /* null ptr => error occurred        */
 851          in_p = ain_p;
 852          in_l = ain_l;
 853          next_in = verify (in_s, " ");
 854          inext_in = next_in;
 855          tch = in_c (next_in);
 856          if tch ^= "("                  /* one char buffer name given        */
 857          then do;
 858             tname = tch;                /* pick up single character name     */
 859             if (index ("(),;", tch) ^= 0)
 860             then do;
 861                msg = "Bbc) Invalid buffer name.";
 862                goto add_str;
 863             end;
 864             tnl = 1;
 865             if (tch = NL)
 866             then goto Bnn;
 867             next_in = next_in + 1;      /* skip index over buffer name       */
 868             tch = ")";
 869          end;
 870          else do;                       /* if multiple characters in name    */
 871             if (substr (in_s, next_in + 1, 1) = "@")
 872             then do;                    /* this is a "current buffer" ref    */
 873                next_in = next_in + 3;
 874                tch = in_c (next_in - 1);
 875                bp = ptr (dbase_p, dbase.cb_c_r);
 876                tname = b.name;
 877                goto addr_check;
 878             end;
 879             if (substr (in_s, next_in, 6) = "((g*))")
 880             then do;
 881                tnl = 4;
 882                tname = "(g*)";
 883                next_in = next_in + 6;
 884             end;
 885             else do;
 886                l = in_l - next_in;      /* find end of buffer name           */
 887                if l < 2
 888                then goto Bmd;
 889                i = next_in + 1;         /* skip over the "("                 */
 890                j = search (substr (in_s, i, l), "),");
 891                if (j < 2)
 892                then do;
 893                   if (j = 0)
 894                   then goto Bmd;
 895 Bnn:
 896                   msg = "Bnn) Null buffer name.";
 897                   goto add_str;
 898                end;
 899                tnl = j - 1;
 900                if (tnl > length (b.name))
 901                then do;
 902                   msg = "Bln) Name > ";
 903                   msg = msg || ltrim (char (length (b.name)));
 904                   msg = msg || " char.";
 905                   goto add_str;
 906                end;
 907                next_in = i + j;         /* set line index after char found   */
 908                tname = substr (in_s, i, tnl); /* pick up buffer name         */
 909             end;
 910             tch = in_c (next_in - 1);   /* pick up stopper character         */
 911          end;
 912          ain_l = next_in - 1;           /* tell how much string used up      */
 913          MTi = 0;
 914          do i = 3 to dbase.bufnum;
 915             if (cb (i).name = "")
 916             then MTi = i;
 917             else do;
 918                if (cb (i).name = tname)
 919                then do;
 920                   bp = addr (cb (i));
 921                   b.noref = "0"b;
 922                   call check_bc;                                      /* #152*/
 923                   goto addr_check;
 924                end;
 925             end;
 926          end;
 927          if create
 928          then do;
 929             call make_buf;
 930 addr_check:
 931             if (tch = ",")
 932             then do;
 933                if (in_c (next_in) = "@")
 934                then do;
 935                   msg = "@ not allowed in this context";
 936                   goto add_str;
 937                end;
 938 /****          b.temp = b.a_;                                                */
 939 /****          b.newb = b.b_;                                                */
 940 /****          if (rel (bp) ^= dbase.cb_c_r)  /* not current buffer?         */
 941 /****          then do;                                                      */
 942 /****             b.newb.l.le = 1;      /* 4/12/82 cant remember why this    */
 943 /****             b.newb.r.re = b.maxl;                                      */
 944 /****          end;                                                          */
 945                used = in_l - next_in + 1;
 946                call tedaddr_ (dbase_p, addr (in_c (next_in)), used, bp,
 947                   msg, code);
 948                next_in = next_in + used + 1;
 949                ain_l = next_in - 1;     /* tell how much string used up      */
 950                if (code > 1)
 951                then do;
 952 add_str:
 953                   msg = msg || " """;
 954                   msg = msg || substr (in_s, inext_in, next_in - inext_in + 1);
 955                   msg = msg || """.";
 956                   goto err_out;
 957                end;
 958                tch = in_c (next_in - 1);
 959                if ^b.present (1)
 960                then b.a_ (1), b.a_ (2) = b.a_ (0);
 961                else do;
 962                   if ^b.present (2)
 963                   then b.a_ (2) = b.a_ (1);
 964                                         /* b.newb.l.ln, b.newb.r.ln = -1;    */
 965                end;
 966             end;
 967             else do;
 968                b.a_.l.ln (1) = 1;
 969                b.a_.r.ln (2) = b.b_.r.ln;
 970                b.a_.l (1) = b.b_.l;
 971                b.a_.l.re (1) = b.a_.l.le (1);
 972                b.a_.r (2) = b.b_.r;
 973                b.a_.r.le (2) = b.a_.r.re (2);
 974                b.present (1), b.present (2) = "0"b;
 975             end;
 976             if (tch ^= ")")
 977             then do;
 978 Bmd:
 979                msg = "Bmd) Missing ).";
 980                goto add_str;
 981             end;
 982          end;
 983          else do;                       /* not found, take error return      */
 984             msg = "Bnf) b(";            /* ***) not found. */ /* ERROR       */
 985             msg = msg || substr (tname, 1, tnl);
 986             msg = msg || ") not found.";
 987 err_out:
 988             bp = null ();
 989             a_msg = msg;
 990          end;
 991       end find_buffer;                                                /* #152*/
 992 out:
 993       abp = bp;                         /* give him what we got              */
 994 out_only:
 995       return; %page;
 996 check_bc: proc;                                                       /* #152*/
 997 
 998       if b.ck_ptr_sw & b.terminate
 999       then call tedck_ptr_ (bp);
1000       if b.get_bit_count
1001       then do;
1002          b.get_bit_count = "0"b;
1003          call hcs_$status_mins (b.cur.sp, 0, arg_l, code);
1004          if (code ^= 0)
1005          then do;
1006             msg = b.name;
1007             call tederror_rc_ (dbase_p, msg, code);
1008             goto out_only;
1009          end;
1010          arg_l = divide (arg_l, 9, 24, 0);
1011          if (arg_l ^= b.b_.l.re)
1012          then do;
1013             b.b_.l.re = arg_l;          /* set changed buffer length         */
1014             b.a_.l.le (0), b.a_.r.le (0) = 1; /* "." undefined               */
1015             b.a_.l.re (0), b.a_.r.re (0) = -1;
1016             b.maxln,                    /* line counts unknown               */
1017                b.a_.r.ln (0), b.a_.l.ln (0) = -1;
1018          end;
1019       end;                                                            /* #152*/
1020    end check_bc;                                                      /* #152*/
1021 
1022 tedcheck_buffer_state_: entry (adb_p, abp, a_msg);                    /* #152*/
1023 
1024       dbase_p = adb_p;                                                /* #152*/
1025       bp = abp;                                                       /* #152*/
1026       call check_bc;                                                  /* #152*/
1027       return;                                                         /* #152*/
1028 %page;
1029 /**** <<<<----- dcl_tedget_segment_.incl.pl1 tedget_segment_                 */
1030 tedget_segment_:                        /* get a segment to work in          */
1031    entry (adb_p, asp, asn);
1032 dcl (
1033 /****adb_p          ptr,                /* -> database                       */
1034     asp             ptr,                /* -> gotten segment           [OUT] */
1035     asn             fixed bin           /* sequence # of it         [IN/OUT] */
1036                                         /* if >0 upon entry, it will then    */
1037                                         /*  fill that entry in seg_p array   */
1038                                         /* otherwise it will take any one    */
1039     )               parm;               /* ----->>>>                         */
1040 
1041       dbase_p = adb_p;
1042       if (asn = 0)
1043       then call get_seg (asp, asn, "getseg  ", code);
1044       else if (asn = 2)
1045       then call get_seg_n (asp, asn, "16Kpool ", code);
1046       else if (asn = 3)
1047       then call get_seg_n (asp, asn, "stk ", code);
1048       else call get_seg_n (asp, asn, "getsegn ", code);
1049 
1050       return; %skip (5);
1051 /**** <<<<----- dcl_tedfree_segment_.incl.pl1 tedfree_segment_               */
1052 tedfree_segment_:                       /* give back a work segment          */
1053    entry (adb_p, asn);
1054 /****dcl (
1055 /****adb_p          ptr,                /* -> database                       */
1056 /****asn            fixed bin           /* sequence # of segment to free     */
1057 /****)              parm;               /* ----->>>>                         */
1058 
1059       dbase_p = adb_p;
1060       call hcs_$truncate_seg (dbase.seg_p (asn), 0, 0);
1061       substr (dbase.inuse_seg, asn, 1) = "0"b;
1062       return; %page;
1063 tederror_rc_:                           /* add return code data to message   */
1064    entry (adb_p, a_msg, rc);
1065 dcl (
1066 /****adb_p          ptr,                /* -> dabatase                       */
1067     a_msg           char (168) var,     /* error message                     */
1068     rc              fixed bin (35)      /* code to include with message      */
1069     )               parm;
1070 
1071 dcl shortinfo       char (8);
1072 dcl longinfo        char (100);
1073 dcl convert_status_code_ entry (fixed bin (35), char (8), char (100));
1074 
1075       call convert_status_code_ (rc, shortinfo, longinfo);
1076 /* RW 88 */
1077       if (rc = error_table_$noentry)
1078       then msg = "Cnf) ";
1079       else if (rc = error_table_$no_component)                        /*#201*/
1080       then msg = "Cnf) ";
1081       else if (rc = error_table_$zero_length_seg)
1082       then msg = "Czl) ";
1083       else msg = "Cxx) ";
1084       msg = msg || rtrim (longinfo);
1085       msg = msg || " ";
1086       msg = msg || a_msg;
1087       call tederror_ (adb_p, msg);
1088       return; %page;
1089 /**** <<<<----- dcl_tedlist_buffers_.incl.pl1 tedlist_buffers_               */
1090 tedlist_buffers_:                       /* show the status of buffers        */
1091    entry (adb_p, select, atest, ln_sw);
1092 dcl (
1093 /****adb_p          ptr,                /* -> database                       */
1094     select          char (16),          /* name of buffer to show            */
1095     atest           bit (1),            /* 0- listing inactive environment   */
1096                                         /* 1- listing active one             */
1097     ln_sw           bit (1)             /* 1- validate b.maxln               */
1098     )               parm;               /* ----->>>>                         */
1099 
1100 dcl buf_ct          fixed bin (21);
1101 dcl line_counts     char (24)var;
1102 dcl Window          char (24)var;                                     /* #140*/
1103 
1104       dbase_p = adb_p;
1105       buf_ct = 0;
1106       arg_bufs = dbase.argct;
1107       if (arg_bufs > 0)
1108       then arg_bufs = arg_bufs + 1;
1109       do ii =
1110          3 + arg_bufs to dbase.bufnum,
1111          3 to 2 + arg_bufs;
1112          bp = addr (cb (ii));
1113          if (b.name ^= "") & ^b.noref
1114          then do;
1115             if atest
1116             then call check_bc;                                       /* #152*/
1117             if (select = " ") | (select = b.name)
1118             then do;
1119                buf_ct = buf_ct + 1;
1120                call fix_buffer_data (atest, ln_sw);
1121                call ioa_ (
1122                   "^a ^[->^;  ^] ^[mod^;   ^] (^a)^a^[ [^^trust]^]"
1123                   || "^[ [^^pasted]^] ^a^[>^a^[:^]^a^a^[   *^]^]",
1124                   line_counts, (rel (bp) = dbase.cb_c_r),
1125                   b.mod_sw, b.name, Window,  ^b.trust_sw, b.not_pasted,
1126                   b.dname, b.file_sw, b.ename, (b.kind = ":"),
1127                   b.kind, b.cname, (b.cur.sn = -1));                  /* #140*/
1128                                         /* print buffer status line          */
1129             end;
1130          end;
1131       end;
1132       if (buf_ct = 0)
1133       then do;
1134          msg = "X: b(";
1135          msg = msg || select;
1136          msg = msg || ") not found";
1137          call tederror_ (adb_p, msg);
1138       end;
1139       return; %page;
1140 dcl in_window       bit (1);
1141 fix_buffer_data: proc (flag, ln_sw);
1142 
1143 dcl flag            bit (1),
1144    ln_sw            bit (1);
1145 
1146 /* RW 88 */
1147 dcl pic7            pic "------9";                                    /*#163*/
1148 dcl hold_maxln      fixed bin (21);
1149 
1150       if (b.cur.sn = 0)                 /* buffer empty?                     */
1151       | (b.b_.l.le > b.b_.l.re) & (b.b_.r.le > b.b_.r.re)             /* #152*/
1152       then do;
1153          b.mod_sw, b.not_pasted = "0"b;
1154          b.maxln = 0;
1155       end;
1156       else if ^(b.file_sw | (b.name = "0"))
1157       then b.mod_sw = "0"b;
1158       if ^b.file_sw
1159       then b.trust_sw = "1"b;
1160       else b.not_pasted = "0"b;
1161       hold_maxln = b.maxln;
1162       if ln_sw & atest
1163       then b.maxln = -1;
1164       if (b.b_.l.le = 1) & (b.b_.r.re = b.maxl)
1165       then do;                                                        /* #140*/
1166          in_window = ""b;                                             /* #140*/
1167          Window = "";                                                 /* #140*/
1168       end;                                                            /* #140*/
1169       else do;                                                        /* #140*/
1170          in_window = "1"b;                                            /* #140*/
1171          Window = " windowed(";                                       /* #140*/
1172          b.maxln = -1;                  /* force linecounting            #140*/
1173       end;                                                            /* #140*/
1174 /* RW 88 */
1175       if (b.maxln < 0)
1176       then string (pic7) = "     ??";                                 /* #140,163*/
1177       else pic7 = b.maxln;                                            /* #140*/
1178       if flag & (b.maxln < 0)
1179       then do;
1180          call tedcount_lines_ (bp, b.b_.l.le, b.b_.r.re, b.maxln);    /* #140*/
1181          if ^in_window                                                /* #140*/
1182          then b.b_.r.ln = b.maxln;
1183          pic7 = b.maxln;                                              /* #140*/
1184       end;
1185       if in_window
1186       then do;                                                        /* #140*/
1187          line_counts = "     ??";                                     /* #140,163*/
1188          Window = Window || pic7;                                     /* #140*/
1189          Window = Window || ")";                                      /* #140*/
1190          b.maxln = -1;                                                /* #140*/
1191       end;                                                            /* #140*/
1192       else line_counts = pic7;                                        /* #140*/
1193       if ln_sw & atest
1194       then do;
1195          pic7 = hold_maxln;
1196          line_counts = line_counts || " <<";
1197          line_counts = line_counts || pic7;
1198       end;
1199 
1200    end fix_buffer_data; %page;
1201 /**** <<<<----- dcl_tedcheck_buffers_.incl.pl1 tedcheck_buffers_             */
1202 tedcheck_buffers_:                      /* check for modified buffers        */
1203    entry (adb_p, check_code);
1204 dcl (
1205 /****adb_p          ptr,                /* -> database                       */
1206     check_code      fixed bin           /* number of modified buffers found  */
1207     )               parm;               /* ----->>>>                         */
1208 
1209       dbase_p = adb_p;
1210       check_code = 0;
1211       do i = 3 to dbase.bufnum;
1212          bp = addr (cb (i));
1213          if b.ck_ptr_sw & b.terminate
1214          then call tedck_ptr_ (bp);
1215          call fix_buffer_data (""b, ""b);
1216          if (b.name ^= "") then                                       /* #139*/
1217          if b.mod_sw | b.not_pasted
1218          then do;
1219             if (check_code = 0)
1220             then call ioa_ ("Modified buffers exist:");
1221             check_code = 1;
1222             call ioa_ ("^[->^;  ^](^a)  ^a^[>^a^[:^]^a^a^]",
1223                (rel (bp) = dbase.cb_c_r),
1224                b.name, b.dname, b.file_sw, b.ename,
1225                (b.kind = ":"), b.kind, b.cname);
1226          end;
1227       end;
1228       return; %page;
1229 tedset_ck_ptr_:                         /* set "check" flag on ^read buffers */
1230    entry (adb_p);
1231 
1232       dbase_p = adb_p;
1233       do ii = 3 to dbase.bufnum;
1234          bp = addr (cb (ii));
1235          if (b.cur.sn = -1) & b.terminate
1236          then b.ck_ptr_sw = "1"b;
1237       end;
1238       return; %skip (3);
1239 /* ------------------------- INTERNAL PROCEDURES --------------------------- */
1240 allocate_cb: proc (cb_ptr, cb_name);
1241 
1242 dcl cb_ptr          ptr,                /* points to new control block [OUT] */
1243     cb_name         char (32);          /* name of new block                 */
1244 
1245 
1246 dcl ii              fixed bin;
1247 dcl new             bit (1);
1248 
1249       dbase.bufnum = dbase.bufnum + 1;
1250       cb_ptr = addr (cb (dbase.bufnum));
1251       new = "1"b;
1252       if ""b
1253       then do;
1254 
1255 re_alloc: entry (cb_ptr, cb_name);
1256          new = ""b;
1257       end;
1258       unspec (cb_ptr -> b) = "0"b;      /* clean everything out              */
1259       do ii = 1 to all_des;
1260          cb_ptr -> buf_des (ii) = tedcommon_$no_data;
1261       end;
1262       cb_ptr -> b.cur = tedcommon_$no_seg;
1263       cb_ptr -> b.ex = tedcommon_$no_data;
1264       cb_ptr -> b.ex.l.le = cb_ptr -> b.ex.l.re + 1;
1265       cb_ptr -> b.name = cb_name;
1266       cb_ptr -> b.dname = "";
1267       cb_ptr -> b.ename = "";
1268       cb_ptr -> b.cname = "";
1269       cb_ptr -> b.kind = "";
1270       cb_ptr -> b.trust_sw = "1"b;
1271       if db_util
1272       then call ioa_$ioa_switch (db_output,
1273          "^[new^;old^]-cb ^d.^d b(^a)", new, env_ct,
1274               dbase.bufnum, cb_name);
1275       if db_util
1276       then call tedshow_ (cb_ptr, ".", ltrim(char(dbase.bufnum)), "bcb");
1277 
1278    end allocate_cb; %skip (4);
1279 get_seg: proc (seg_dp, seg_id_no, seg_use, a_code);
1280 
1281       seg_id_no = 0;                    /* set seq # unspecified             */
1282 
1283 get_seg_n: entry (seg_dp, seg_id_no, seg_use, a_code);
1284 
1285 dcl (
1286     seg_dp          ptr,                /* ptr to gotten segment       [OUT] */
1287     seg_id_no       fixed bin,          /* sequence # of segment    [IN/OUT] */
1288     seg_use         char (8),           /* use of the segment (db info)      */
1289     a_code          fixed bin (35)
1290     )               parm;
1291 
1292       if (seg_id_no = 0)                /* if no slot specified, look..      */
1293       then                              /*   ..for an unused one             */
1294            seg_id_no = index (substr (dbase.inuse_seg, 4), "0"b) + 3;
1295       if (seg_id_no > dbase.seg_ct)     /* there wasn't one so we're using.. */
1296       then dbase.seg_ct = seg_id_no;    /* ..a new one                       */
1297                                         /* (Really should check for 72 seg   */
1298                                         /* ..limit being exceeded.)          */
1299       seg_dp = dbase.seg_p (seg_id_no); /* get contents of this slot         */
1300       if (seg_dp ^= null ())            /* is there something there?         */
1301       then do;                          /*   YES                             */
1302          substr (dbase.inuse_seg, seg_id_no, 1) = "1"b;
1303          goto exit;
1304       end;
1305 
1306 dcl dirname         char (168);
1307 dcl myname          char (32) var;
1308 dcl ename           char (32);
1309 dcl i               fixed bin;
1310 
1311 get_base: entry (seg_dp, seg_id_no, seg_use, a_code);
1312 
1313       a_code = 0;
1314       ename = "ted_.yymmddHHMMSS.UUUUUU.000";
1315       if (dbase_p = null ())            /* getting the database segment      */
1316       then do;
1317          substr (ename, 6, 19) = rqid;
1318          substr (ename, 26) = "X";
1319          dirname = db_dir;
1320          if db_util
1321          then call ioa_$ioa_switch (db_output,
1322             " ^[[pd]^s^;^a^] > ^a", (dirname = ""), dirname, ename);
1323          myname = ted_data.tedname;
1324       end;
1325       else do;                          /* getting an auxiliary segment      */
1326 /**** This routine enters new entries into dbase.seg_p. demote handles the   */
1327 /****  freeing of them during execution. (cleanup, of course, cleans them    */
1328 /****  all out at termination time.)                                         */
1329          substr (dbase.inuse_seg, seg_id_no, 1) = "1"b;
1330          substr (ename, 6, 19) = dbase.rq_id;
1331          substr (ename, 26) = convert (pic3, seg_id_no);
1332          dirname = dbase.dir_db;
1333          myname = dbase.tedname;
1334       end;
1335       seg_dp = null ();
1336       if (dirname ^= "")                /* -safe/-temp_dir environment       */
1337       then do;
1338          call hcs_$make_seg (dirname, ename, "", 01011b, seg_dp, a_code);
1339          if (seg_dp = null ())
1340          then do;
1341             call com_err_ (a_code, myname, "get_seg(^a>^a)",
1342                dirname, ename);
1343             goto abort_no_print;
1344          end;
1345          a_code = 0;
1346       end;
1347       else do;                          /* environment is in [pd]            */
1348          call get_temp_segment_ ((myname), seg_dp, a_code);
1349          if (a_code ^= 0)
1350          then do;
1351             msg = "Getting temp segment";
1352             goto abort_print;
1353          end;
1354       end;
1355       if (dbase_p ^= null ())
1356       then dbase.seg_p (seg_id_no) = seg_dp;
1357       else do;
1358          do i = -1 to 72;               /* initialize the ptr array          */
1359             seg_dp -> dbase.seg_p (i) = null ();
1360          end;
1361          seg_dp -> dbase.seg_p (0) = seg_dp; /* just for  completeness      */
1362          seg_dp -> dbase.seg_ct = 2;    /* reserve 1 and 2                   */
1363          string (seg_dp -> dbase.sws) = "0"b;
1364          if (db_dir ^= "")              /* The temp_dir given may not be the */
1365          then do;                       /*  home_dir. Try to link to the     */
1366                                         /*  segment we just created          */
1367             call hcs_$append_link (get_default_wdir_ (), ename,
1368                rtrim (dirname) || ">" || ename, a_code);
1369                                         /* If a name duplication then        */
1370                                         /*  temp_dir IS home_dir, no sweat   */
1371             if (a_code ^= 0)
1372             then do;
1373                if (a_code ^= error_table_$namedup)
1374                then call com_err_ (a_code, ted_data.tedname,
1375                        "Trying to link to remote dbase ^a>^a.",
1376                        rtrim (dirname), ename);
1377             end;
1378             else seg_dp -> dbase.remote_sw = "1"b;
1379 
1380          end;
1381       end;
1382 exit:
1383       if db_util
1384       then call ioa_$ioa_switch (db_output,
1385          "get_seg ^3d ^p ^a", seg_id_no, seg_dp, seg_use);
1386 
1387    end get_seg;
1388 %page;
1389 start: proc;
1390 
1391 /**** This is a clean segment, so all fields which need to be initialized to */
1392 /**** zero are left alone.                                                   */
1393 
1394       if db_util then call ioa_$ioa_switch (db_output,
1395          "begin start");
1396       dbase.tedname = ted_data.tedname; /* these 3 values                    */
1397       dbase.dir_db = db_dir;            /* ..must be set                     */
1398       dbase.rq_id = rqid;               /* ..before calling get_seg          */
1399       dbase.cba_p = addr (cb (1));
1400       dbase.eval_p = null ();
1401       dbase.version = dbase_vers_3;
1402    /*** dbase.seg_p(*) is initialized by get_base                  */
1403 
1404       dbase.time = startup;
1405       dbase.argct = ted_data.arg_list_n - max (1, ted_data.arg_list_1) + 1;
1406       call user_info_ (dbase.person, dbase.project);
1407       dbase.nulreq = "p";
1408       dbase.err_go = "";
1409       dbase.recurs = env_ct + 1;
1410 
1411 /****                       init call stack data                             */
1412       dbase.stk_info.top = null ();
1413       dbase.stk_info.curp = addr (cb (1));
1414       dbase.stk_info.level = 0;
1415       dbase.stk_info.next = 1;
1416 
1417 /****                        request buffer space                            */
1418       bp = addr (cb (0));
1419       call re_alloc (bp, "(request line)");
1420       call tedpromote_ (bp, 4096);      /* get some buffer space             */
1421       dbase.rl.part1 = b.cur;
1422       dbase.rl.part2 = b.b_;
1423 
1424 /****                      allocate the console cb                           */
1425       call allocate_cb (bp, "(ted)");   /* ted_ will allocate the space      */
1426       call tedpromote_ (bp, 4096);      /* get some buffer space             */
1427       b.tw_sw = "1"b;                   /* ..where data will be read         */
1428       b.terminate = "0"b;
1429 
1430 /****                          allocate val cb                               */
1431 
1432       call allocate_cb (bp, "(val)");
1433       dbase.eval_p = bp;                /* a "buffer" segment will be gotten */
1434                                         /*  if evaluation is ever used.      */
1435 
1436 /****                        process arg buffers                             */
1437 
1438       if (dbase.argct > 0)
1439       then do;
1440          call allocate_cb (bp, "args");
1441          b.noref = "1"b;
1442 dcl arg_no          fixed bin;
1443 dcl tbp             ptr;
1444          i = 0;                         /* first find out how many chars     */
1445          do arg_no = ted_data.arg_list_1 to ted_data.arg_list_n;
1446             call cu_$arg_ptr_rel (arg_no, arg_p, arg_l, code,
1447                ted_data.arg_list_p);
1448             i = i + arg_l + 1;
1449          end;
1450          call tedpromote_ (bp, i);      /* get enough room for args          */
1451          b.a_.r.le (0), b.a_.r.re (0) = -1;
1452          b.maxln = dbase.argct;
1453          b.pseudo = "1"b;
1454          b.cur.ast = 0;                 /* (make promotion work)             */
1455          i = 1;
1456          do arg_no = ted_data.arg_list_1 to ted_data.arg_list_n;
1457             call cu_$arg_ptr_rel (arg_no, arg_p, arg_l, code,
1458                ted_data.arg_list_p);
1459             substr (b_s, b.b_.l.re + 1, arg_l) = arg;
1460             call allocate_cb (tbp, "arg" || ltrim (char (i)));
1461             i = i + 1;
1462 /****       Leave buffer empty if no data to put there.                      */
1463             if (arg_l > 0)
1464             then call tedpseudo_ (tbp, b.cur.sn, addr (b_c (b.b_.l.re + 1)), arg_l);
1465             tbp -> b.a_.r.le (0), tbp -> b.a_.r.re (0) = -1;
1466             tbp -> b.maxln = fixed (arg_l > 0);
1467             tbp -> b.noref = "1"b;
1468             b.b_.l.re = b.b_.l.re + arg_l + 1;
1469             b_c (b.b_.l.re) = NL;
1470          end;
1471       end;
1472 
1473 /*        allocate b(0) cb    */
1474 
1475       call allocate_cb (bp, "0");
1476       dbase.cb_c_r = rel (bp);
1477 
1478       if db_util then call ioa_$ioa_switch (db_output,
1479          "end start");
1480 
1481    end; %page;
1482 restart: proc;
1483 
1484 
1485       if (dbase.version ^= dbase_vers_3)
1486       then do;
1487          call com_err_ (0, dbase.tedname,
1488             "Old version of ted dbase, cannot restart.");
1489          goto abort_no_print;
1490       end;
1491       if db_util then call tedshow_ (dbase_p, "> restart base");
1492 
1493       dbase.seg_p (0) = dbase_p;
1494       do i = 1 to dbase.seg_ct;
1495          if (dbase.seg_p (i) ^= null ())
1496          then do;
1497             dbase.seg_p (i) = null ();
1498             call get_seg_n (dbase.seg_p (i), (i), "reget_n ", code);
1499             if (code ^= 0)
1500             then goto abort_print;
1501          end;
1502       end;
1503       dbase.eval_p = addr (cb (2));
1504       dbase.cba_p = addr (cb (1));
1505       do i = 0 to dbase.bufnum;
1506          bp = addr (cb (i));
1507          if (b.cur.sn = -1)
1508          then do;
1509             if cb (i).terminate | cb (i).initiate
1510             then do;
1511                addr (cb (i).cur.sp) -> its.segno = "77777"b3;
1512                call tedck_ptr_ (addr (cb (i)));
1513             end;
1514          end;
1515          if (b.cur.sn > 0)              /* was this an active pointer?       */
1516          then addr (b.cur.sp) -> its.segno
1517                  = addr (dbase.seg_p (b.cur.sn)) -> its.segno;
1518          if (b.pend.sn > 0)             /* was this an active pointer?       */
1519          then addr (b.pend.sp) -> its.segno
1520                  = addr (dbase.seg_p (b.pend.sn)) -> its.segno;
1521       end;
1522       dbase.rl.part1 = cb (0).cur;
1523       dbase.recurs = env_ct + 1;
1524       dbase.stk_info.top = null ();
1525       dbase.stk_info.curp = addr (cb (1));
1526       dbase.stk_info.level = 0;
1527 
1528       if db_util then call tedshow_ (dbase_p, "< restart base");
1529       return;
1530 
1531 
1532    end restart; %page;
1533 dcl (addr, char, divide, fixed, index, length, null, search, substr,
1534     verify)         builtin;
1535 
1536 %include ted_;
1537 %include tedbase;
1538 %include tedbcb;
1539 %include tedstk;
1540 %include tederror_;
1541 %include tedcommon_;
1542 dcl tedmgr_$list    entry;
1543 dcl tedaddr_        entry (             /* process request addresses         */
1544                     ptr,                /* -> database                       */
1545                     ptr,                /* -> string containing address      */
1546                     fixed bin (21),     /*   length of it               [IN] */
1547                                         /* If <0 then recursive call         */
1548                                         /*   how much was used up      [OUT] */
1549                     ptr,                /* -> buffer control block  [IN/OUT] */
1550                     char (168) var,     /* place to hold err message if any  */
1551                     fixed bin (35),     /* status code                       */
1552                                         /*   0- null address                 */
1553                                         /*   1- address found                */
1554                                         /*   8- error, msg tells what        */
1555                     );
1556 
1557 
1558 dcl tedck_ptr_      entry (ptr);
1559 dcl tedcount_lines_ entry (             /* return # lines in string          */
1560                     ptr,                /* -> buffer in which to count       */
1561                     fixed bin (21),     /* where string begins in segment    */
1562                     fixed bin (21),     /* where string ends in segment      */
1563                     fixed bin (21)      /* # lines                     [OUT] */
1564                     );
1565 
1566 
1567 dcl tedcloseup_     entry (             /* move all buffer data to lower     */
1568                     ptr                 /* -> to buffer to convert           */
1569                     );
1570 
1571 
1572 dcl tedpromote_     entry (             /* get a larger data buffer          */
1573                     ptr,                /* -> buffer to promote              */
1574                     fixed bin (21)      /* amount not fitting                */
1575                     );
1576 
1577 
1578 dcl tedpseudo_      entry (             /* make a pseudo (read-only) buffer  */
1579                     ptr,                /* -> to buffer to convert           */
1580                     fixed bin,          /* segno of data (-1 if ^read)       */
1581                     ptr,                /* -> the data                       */
1582                     fixed bin (21)      /* the length of it                  */
1583                     );
1584 
1585 
1586 dcl tedshow_        entry options (variable);
1587 %include its;
1588    end tedmgr_;