1 /*
   2 Multics Inquire personal information database manager
   3 (c) Copyright 1981 by Massachussetts Institute of Technology
   4 
   5 Written: Summer, Fall 1981 by Barry Margolin
   6 */
   7 
   8 /* format: style2 */
   9 
  10 /* To do:
  11       use sub_err_ (perhaps non-standard error code instead)
  12       Add entry points:
  13           (set get)_all (set_all is started)
  14           get_field_names? (if field names get more complex)
  15       Dumping and restructuring
  16       field name synonyms
  17       Date-time-modified
  18       read-only fields (maintained by system, i.e. dtm)
  19       Logging?
  20 */
  21 inquire_r3_:
  22      proc;
  23           return;
  24 
  25           dcl     retrieved_userid       char (20);
  26           dcl     code                   fixed bin (35) init (0);
  27           dcl     whoami                 char (11) int static options (constant) init ("inquire_r3_");
  28           dcl     unlock_on_cleanup      bit (1);
  29 
  30           /*** Structures ***/
  31 
  32           dcl     1 inquire_data         like user;         /* Data structure for MRDS calls */
  33           dcl     1 inquire_data_array   based (addr (inquire_data)),
  34                     2 private_entry      bit (1),
  35                     2 fields             (inquire_data_$field_count),
  36                       3 contents         char (200) varying,
  37                       3 private          bit (1);
  38           dcl     field_numbers          (inquire_data_$field_count) fixed bin (17);
  39 
  40           /*** Entries ***/
  41 
  42           dcl     user_info_$whoami      entry options (variable);
  43           dcl     dsl_$open              entry () options (variable);
  44           dcl     dsl_$close             entry () options (variable);
  45           dcl     dsl_$retrieve          entry () options (variable);
  46           dcl     dsl_$store             entry () options (variable);
  47           dcl     dsl_$delete            entry () options (variable);
  48           dcl     dsl_$modify            entry () options (variable);
  49           dcl     dsl_$set_scope         entry () options (variable);
  50           dcl     dsl_$dl_scope          entry () options (variable);
  51           dcl     dsl_$get_scope         entry (fixed bin (35), char (*), fixed bin, fixed bin, fixed bin, fixed bin (35))
  52                                          ;
  53           dcl     (get_temp_segment_, release_temp_segment_)
  54                                          entry (char (*), ptr, fixed bin (35));
  55           dcl     hcs_$level_get         entry () returns (fixed bin (3));
  56           dcl     hcs_$level_set         entry (fixed bin (3));
  57           dcl     get_ring_              entry () returns (fixed bin (3));
  58           dcl     add_epilogue_handler_  entry (entry, fixed bin (35));
  59           dcl     inquire_lock_$init     entry (fixed bin (35));
  60           dcl     inquire_lock_$lock     entry (bit (1), fixed bin (35));
  61           dcl     inquire_lock_$unlock   entry (fixed bin (35));
  62 
  63           /*** External Constants ***/
  64 
  65           dcl     inquire_data_$db_path  char (168) external;
  66           dcl     inquire_data_$rel_name char (32) external;
  67           dcl     inquire_data_$field_names
  68                                          external;          /* This is here for its external address */
  69                                                             /* *** Declared in inquire_dcls.incl.pl1 ***
  70           dcl     inquire_data_$field_count
  71                                          external fixed bin;
  72 */
  73           dcl     known_field_names      (inquire_data_$field_count) char (32) based (addr (inquire_data_$field_names));
  74 
  75 
  76           /*** Flags ***/
  77 
  78           dcl     database_locked        bit (1) static internal init ("0"b);
  79           dcl     privileged             bit (1);
  80 
  81           /*** Inner Ring Static */
  82 
  83           dcl     caller_userid          char (20) static internal;
  84 
  85           /*** Temporaries ***/
  86 
  87           dcl     (i, j, bad_field)      fixed bin;
  88           dcl     (user_ring, inner_ring)
  89                                          fixed bin (3);
  90           dcl     temp_seg_ptr           ptr init (null);
  91           dcl     (userid, lname)        char (200) varying;
  92           dcl     user_area              area based (area_ptr);
  93           dcl     area_ptr               ptr;               /* From the input to various entrypoints */
  94           /*** Builtins ***/
  95 
  96           dcl     (null, addr)           builtin;
  97 
  98           /*** Error codes ***/
  99 
 100           dcl     (
 101                   inquire_et_$bad_recursion,
 102                   inquire_et_$cant_set_userid,
 103                   inquire_et_$invalid_field,
 104                   inquire_et_$not_open,
 105                   inquire_et_$no_entry,
 106                   inquire_et_$int_error_no_entry,
 107                   inquire_et_$int_error_dup_key,
 108                   inquire_et_$db_busy,
 109                   inquire_et_$int_error_db_busy,
 110                   mrds_error_$db_busy,
 111                   mrds_error_$scope_not_empty,
 112                   mrds_error_$dup_key,
 113                   mrds_error_$tuple_not_found
 114                   )                      fixed bin (35) static external;
 115 
 116           /*** Conditions */
 117 
 118           dcl     cleanup                condition;
 119 ^L
 120           /*** Include files ***/
 121 
 122 /* Include file genrated by create_mrds_dm_include (declares the user structure) */
 123 %include inquire;
 124 ^L
 125 %include inquire_dcls;
 126 ^L
 127 %include mrds_new_scope_modes;
 128 ^L
 129 %include mrds_opening_modes_;
 130 ^L
 131           /*** Parameters for entrypoints ***/
 132 
 133           dcl     P_userid               char (*) varying;  /* Input userid */
 134           dcl     P_lname                char (*) varying;  /* Input last name */
 135           dcl     P_privacy_flag         bit (1);           /* Entry privacy setting (input or output) */
 136           dcl     P_privacy_flags_ptr    ptr;               /* Privacy settings (input or output) */
 137           dcl     P_field_names_ptr      pointer;           /* Pointer to a structure containing the requested field names */
 138           dcl     P_area_ptr             pointer;           /* Area to allocate output */
 139           dcl     P_field_values_ptr     pointer;           /* Pointer to structure of values (output for fields_from_*, else input) */
 140           dcl     P_userids_ptr          ptr;               /* Pointer to array of userids (output) */
 141           dcl     P_userid_count         fixed bin (17);    /* Count of userids in database (output) */
 142           dcl     P_code                 fixed bin (35);    /* What else? */
 143 ^L
 144 fields_from_userid:
 145      entry (P_userid, P_field_names_ptr, P_area_ptr, P_field_values_ptr, P_code);
 146 
 147           privileged = "0"b;
 148           go to ffu_JOIN;
 149 
 150 priv_fields_from_userid:
 151      entry (P_userid, P_field_names_ptr, P_area_ptr, P_field_values_ptr, P_code);
 152 
 153           privileged = "1"b;
 154 
 155 
 156 ffu_JOIN:
 157           area_ptr = P_area_ptr;
 158           on cleanup call cleanup_proc ();
 159           call start_up (code);
 160           if code ^= 0
 161           then do;
 162                     P_code = code;
 163                     call cleanup_proc ();
 164                     return;
 165                end;
 166 
 167           P_code = 0;                                       /* Don't screw him */
 168           inq_field_names_ptr = P_field_names_ptr;
 169 
 170           if P_userid = "" | P_userid = rtrim (caller_userid)
 171           then do;                                          /* Null string means caller's entry */
 172                     userid = rtrim (caller_userid);
 173                     privileged = "1"b;
 174                end;
 175           else userid = P_userid;
 176 
 177           call convert_field_names (bad_field);
 178           if bad_field ^= 0
 179           then do;                                          /* Make sure all the field names are valid Inquire fields */
 180                     P_code = -bad_field;                    /* Return negative of the incorrect field index */
 181                     call cleanup_proc ();
 182                     return;
 183                end;
 184 
 185           call get_temp_segment_ (whoami, temp_seg_ptr, code);
 186           if code ^= 0
 187           then do;
 188                     P_code = code;
 189                     call cleanup_proc ();
 190                     return;
 191                end;
 192           inq_field_values_ptr = temp_seg_ptr;
 193 
 194           inq_field_values.entry_count = 0;                 /* Initialize work structure */
 195           inq_field_values.value_count = inq_field_names.name_count;
 196 
 197           call lock_db_read (code);
 198           if code ^= 0
 199           then do;
 200                     P_code = code;
 201                     call cleanup_proc ();
 202                     return;
 203                end;
 204 
 205           call retrieve_entry ("userid", rtrim (userid), code);
 206           if code ^= 0
 207           then do;
 208                     P_code = code;
 209                     call cleanup_proc ();
 210                     return;
 211                end;
 212           call unlock_db (code);
 213           if code ^= 0
 214           then do;
 215                     P_code = code;
 216                     call cleanup_proc ();
 217                     return;
 218                end;
 219 
 220           if privileged
 221           then call fill_work_structure ();
 222           else call fill_work_structure_check ();
 223 
 224           if inq_field_values.entry_count = 0               /* Private entry */
 225           then do;
 226                     P_code = inquire_et_$no_entry;
 227                     call cleanup_proc ();
 228                     return;
 229                end;
 230           else do;
 231                     inq_fv_size = inq_field_values.entry_count;
 232                     allocate inq_field_values in (user_area) set (P_field_values_ptr);
 233                     P_field_values_ptr -> inq_field_values = inq_field_values;
 234                     P_code = 0;
 235                end;
 236 
 237           call cleanup_proc ();
 238           return;
 239 ^L
 240 fields_from_lname:
 241      entry (P_lname, P_field_names_ptr, P_area_ptr, P_field_values_ptr, P_code);
 242 
 243           privileged = "0"b;
 244           go to ffl_JOIN;
 245 
 246 priv_fields_from_lname:
 247      entry (P_lname, P_field_names_ptr, P_area_ptr, P_field_values_ptr, P_code);
 248 
 249           privileged = "1"b;
 250 
 251 ffl_JOIN:
 252           area_ptr = P_area_ptr;
 253           on cleanup call cleanup_proc ();
 254           call start_up (code);
 255           if code ^= 0
 256           then do;
 257                     P_code = code;
 258                     call cleanup_proc ();
 259                     return;
 260                end;
 261 
 262           P_code = 0;                                       /* Don't screw him */
 263           lname = P_lname;
 264           inq_field_names_ptr = P_field_names_ptr;
 265 
 266           call convert_field_names (bad_field);
 267           if bad_field ^= 0
 268           then do;                                          /* Make sure all the field names are valid Inquire fields */
 269                     P_code = -bad_field;                    /* Return negative of invalid field index */
 270                     call cleanup_proc ();
 271                     return;
 272                end;
 273 
 274 
 275           call get_temp_segment_ (whoami, temp_seg_ptr, code);
 276           if code ^= 0
 277           then do;
 278                     P_code = code;
 279                     call cleanup_proc ();
 280                     return;
 281                end;
 282           inq_field_values_ptr = temp_seg_ptr;
 283           inq_field_values.entry_count = 0;
 284           inq_field_values.value_count = inq_field_names.name_count;
 285 
 286           call lock_db_read (code);
 287           if code ^= 0
 288           then do;
 289                     P_code = code;
 290                     call cleanup_proc ();
 291                     return;
 292                end;
 293 
 294           /*** Get the first one ***/
 295           call retrieve_entry ("last_name", rtrim (lname), code);
 296           if code ^= 0
 297           then do;
 298                     P_code = code;
 299                     call cleanup_proc ();
 300                     return;
 301                end;
 302 
 303           if privileged | retrieved_userid = rtrim (caller_userid)
 304           then call fill_work_structure ();
 305           else call fill_work_structure_check ();
 306 
 307           /*** Get more of them ***/
 308           do while ("1"b);
 309                call retrieve_another (code);                /* Get the data */
 310                if code ^= 0
 311                then do;
 312                          if code = inquire_et_$no_entry
 313                          then go to ffl_RETURN_VALS;        /* Just return what we have in that case */
 314                          else do;
 315                                    P_code = code;
 316                                    call cleanup_proc ();
 317                                    return;
 318                               end;
 319                     end;
 320 
 321                if privileged | retrieved_userid = rtrim (caller_userid)
 322                then call fill_work_structure ();
 323                else call fill_work_structure_check ();
 324           end;
 325 
 326 ffl_RETURN_VALS:
 327           call unlock_db (code);
 328           if code ^= 0
 329           then do;
 330                     P_code = code;
 331                     call cleanup_proc ();
 332                     return;
 333                end;
 334 
 335           if inq_field_values.entry_count = 0               /* No accesible entries */
 336           then do;
 337                     P_code = inquire_et_$no_entry;
 338                     call cleanup_proc ();
 339                     return;
 340                end;
 341           else do;
 342                     inq_fv_size = inq_field_values.entry_count;
 343                     allocate inq_field_values in (user_area) set (P_field_values_ptr);
 344                     P_field_values_ptr -> inq_field_values = inq_field_values;
 345                     P_code = 0;
 346                end;
 347 
 348           call cleanup_proc ();
 349           return;
 350 ^L
 351 set_fields:
 352      entry (P_field_names_ptr, P_field_values_ptr, P_code);
 353 
 354           privileged = "0"b;
 355           go to sf_JOIN;
 356 
 357 priv_set_fields:
 358      entry (P_userid, P_field_names_ptr, P_field_values_ptr, P_code);
 359 
 360           privileged = "1"b;
 361 
 362 sf_JOIN:
 363           on cleanup call cleanup_proc ();
 364           call start_up (code);
 365           if code ^= 0
 366           then do;
 367                     P_code = code;
 368                     call cleanup_proc ();
 369                     return;
 370                end;
 371 
 372           P_code = 0;                                       /* Don't screw him */
 373           inq_field_names_ptr = P_field_names_ptr;
 374           inq_field_values_ptr = P_field_values_ptr;
 375 
 376           if privileged
 377           then userid = P_userid;
 378           else userid = rtrim (caller_userid);
 379           if userid = ""
 380           then userid = rtrim (caller_userid);
 381 
 382           call convert_field_names (bad_field);
 383           if bad_field ^= 0
 384           then do;                                          /* Make sure all the field names are valid Inquire fields */
 385                     P_code = -bad_field;                    /* Return negative of invalid field index */
 386                     call cleanup_proc ();
 387                     return;
 388                end;
 389 
 390           call lock_db_write (code);
 391           if code ^= 0
 392           then do;
 393                     P_code = code;
 394                     call cleanup_proc ();
 395                     return;
 396                end;
 397 
 398           call modify_entry (userid, code);
 399           if code ^= 0
 400           then do;
 401                     P_code = code;
 402                     call cleanup_proc ();
 403                     return;
 404                end;
 405 
 406           call unlock_db (P_code);
 407 
 408           call cleanup_proc ();
 409           return;
 410 ^L
 411 get_field_privacy_flags:
 412      entry (P_field_names_ptr, P_privacy_flags_ptr, P_code);
 413           privileged = "0"b;
 414           go to gfpf_JOIN;
 415 
 416 priv_get_field_privacy_flags:
 417      entry (P_userid, P_field_names_ptr, P_privacy_flags_ptr, P_code);
 418 
 419           privileged = "1"b;
 420 
 421 
 422 gfpf_JOIN:
 423           on cleanup call cleanup_proc ();
 424           call start_up (code);
 425           if code ^= 0
 426           then do;
 427                     P_code = code;
 428                     call cleanup_proc ();
 429                     return;
 430                end;
 431 
 432           P_code = 0;                                       /* Don't screw him */
 433           inq_field_names_ptr = P_field_names_ptr;
 434           inq_field_privacies_ptr = P_privacy_flags_ptr;
 435 
 436           if privileged
 437           then userid = P_userid;
 438           else userid = rtrim (caller_userid);
 439           if userid = ""
 440           then userid = rtrim (caller_userid);
 441 
 442           call convert_field_names (bad_field);
 443           if bad_field ^= 0
 444           then do;                                          /* Make sure all the field names are valid Inquire fields */
 445                     P_code = -bad_field;                    /* Return negative of invalid field index */
 446                     call cleanup_proc ();
 447                     return;
 448                end;
 449 
 450           inq_field_privacies.value_count = inq_field_names.name_count;
 451 
 452           call lock_db_read (code);
 453           if code ^= 0
 454           then do;
 455                     P_code = code;
 456                     call cleanup_proc ();
 457                     return;
 458                end;
 459 
 460           call retrieve_entry ("userid", rtrim (userid), code);
 461           if code ^= 0
 462           then do;
 463                     P_code = code;
 464                     call cleanup_proc ();
 465                     return;
 466                end;
 467           call unlock_db (code);
 468           if code ^= 0
 469           then do;
 470                     P_code = code;
 471                     call cleanup_proc ();
 472                     return;
 473                end;
 474 
 475           call fill_privacy_structure ();
 476 
 477           call cleanup_proc ();
 478           return;
 479 ^L
 480 set_field_privacy_flags:
 481      entry (P_field_names_ptr, P_privacy_flags_ptr, P_code);
 482 
 483           privileged = "0"b;
 484           goto sfpf_JOIN;
 485 
 486 priv_set_field_privacy_flags:
 487      entry (P_userid, P_field_names_ptr, P_privacy_flags_ptr, P_code);
 488 
 489           privileged = "1"b;
 490 
 491 sfpf_JOIN:
 492           on cleanup call cleanup_proc;
 493           call start_up (code);
 494           if code ^= 0
 495           then do;
 496                     P_code = code;
 497                     call cleanup_proc ();
 498                     return;
 499                end;
 500 
 501           P_code = 0;                                       /* Don't screw him */
 502           inq_field_names_ptr = P_field_names_ptr;
 503           inq_field_privacies_ptr = P_privacy_flags_ptr;
 504 
 505           if privileged
 506           then userid = P_userid;
 507           else userid = rtrim (caller_userid);
 508           if userid = ""
 509           then userid = rtrim (caller_userid);
 510 
 511           call convert_field_names (bad_field);
 512           if bad_field ^= 0
 513           then do;                                          /* Make sure all the field names are valid Inquire fields */
 514                     P_code = -bad_field;                    /* Return negative of invalid field index */
 515                     call cleanup_proc ();
 516                     return;
 517                end;
 518 
 519           call lock_db_write (code);
 520           if code ^= 0
 521           then do;
 522                     P_code = code;
 523                     call cleanup_proc ();
 524                     return;
 525                end;
 526 
 527           call modify_entry_privacy (userid, code);
 528           if code ^= 0
 529           then do;
 530                     P_code = code;
 531                     call cleanup_proc;
 532                     return;
 533                end;
 534 
 535           call unlock_db (code);
 536           if code ^= 0
 537           then do;
 538                     P_code = code;
 539                     call cleanup_proc ();
 540                     return;
 541                end;
 542 
 543           call cleanup_proc ();
 544           return;
 545 ^L
 546 get_entry_privacy_flag:
 547      entry (P_privacy_flag, P_code);
 548 
 549           privileged = "0"b;
 550           go to gepf_JOIN;
 551 
 552 priv_get_entry_privacy_flag:
 553      entry (P_userid, P_privacy_flag, P_code);
 554 
 555           privileged = "1"b;
 556 
 557 gepf_JOIN:
 558           on cleanup call cleanup_proc ();
 559           call start_up (code);
 560           if code ^= 0
 561           then do;
 562                     P_code = code;
 563                     call cleanup_proc ();
 564                     return;
 565                end;
 566 
 567           P_code = 0;                                       /* Don't screw him */
 568 
 569           if privileged
 570           then userid = P_userid;
 571           else userid = rtrim (caller_userid);
 572           if userid = ""
 573           then userid = rtrim (caller_userid);
 574 
 575           call lock_db_read (code);
 576           if code ^= 0
 577           then do;
 578                     P_code = code;
 579                     call cleanup_proc ();
 580                     return;
 581                end;
 582 
 583           call retrieve_entry ("userid", rtrim (userid), code);
 584           if code ^= 0
 585           then do;
 586                     P_code = code;
 587                     call cleanup_proc ();
 588                     return;
 589                end;
 590           call unlock_db (code);
 591           if code ^= 0
 592           then do;
 593                     P_code = code;
 594                     call cleanup_proc ();
 595                     return;
 596                end;
 597 
 598           P_privacy_flag = inquire_data_array.private_entry;
 599 
 600           call cleanup_proc ();
 601           return;
 602 ^L
 603 set_entry_privacy_flag:
 604      entry (P_privacy_flag, P_code);
 605 
 606           privileged = "0"b;
 607           go to sepf_JOIN;
 608 
 609 priv_set_entry_privacy_flag:
 610      entry (P_userid, P_privacy_flag, P_code);
 611 
 612           privileged = "1"b;
 613 
 614 sepf_JOIN:
 615           on cleanup call cleanup_proc ();
 616           call start_up (code);
 617           if code ^= 0
 618           then do;
 619                     P_code = code;
 620                     call cleanup_proc ();
 621                     return;
 622                end;
 623 
 624           P_code = 0;                                       /* Don't screw him */
 625 
 626           if privileged
 627           then userid = P_userid;
 628           else userid = rtrim (caller_userid);
 629           if userid = ""
 630           then userid = rtrim (caller_userid);
 631 
 632           call lock_db_write (code);
 633           if code ^= 0
 634           then do;
 635                     P_code = code;
 636                     call cleanup_proc ();
 637                     return;
 638                end;
 639 
 640           call modify_private_entry_flag (userid, P_privacy_flag, code);
 641           if code ^= 0
 642           then do;
 643                     P_code = code;
 644                     call cleanup_proc ();
 645                     return;
 646                end;
 647 
 648           call unlock_db (P_code);
 649 
 650           call cleanup_proc ();
 651           return;
 652 ^L
 653 close_db:
 654      entry (P_code);
 655 
 656           on cleanup call cleanup_proc ();
 657 
 658           call start_up_no_open (code);                     /* Don't open if we're just going to close it */
 659           if code ^= 0
 660           then P_code = code;
 661           else call close_database (P_code);
 662 
 663           call cleanup_proc ();
 664           return;
 665 ^L
 666 get_all_userids:
 667      entry (P_area_ptr, P_userids_ptr, P_userid_count, P_code);
 668 
 669           dcl     userid_array           (userid_count) char (20) varying based (userid_ptr);
 670           dcl     userid_ptr             ptr;
 671           dcl     userid_count           fixed bin (17);
 672 
 673           privileged = "0"b;
 674           go to gau_JOIN;
 675 
 676 priv_get_all_userids:
 677      entry (P_area_ptr, P_userids_ptr, P_userid_count, P_code);
 678 
 679           privileged = "1"b;
 680 
 681 gau_JOIN:
 682           area_ptr = P_area_ptr;
 683           on cleanup call cleanup_proc ();
 684           call start_up (code);
 685           if code ^= 0
 686           then do;
 687                     P_code = code;
 688                     call cleanup_proc ();
 689                     return;
 690                end;
 691 
 692           P_code = 0;                                       /* Don't screw him */
 693 
 694           call get_temp_segment_ (whoami, temp_seg_ptr, code);
 695           if code ^= 0
 696           then do;
 697                     P_code = code;
 698                     call cleanup_proc ();
 699                     return;
 700                end;
 701           userid_ptr = temp_seg_ptr;
 702 
 703           call lock_db_read (code);
 704           if code ^= 0
 705           then do;
 706                     P_code = code;
 707                     call cleanup_proc ();
 708                     return;
 709                end;
 710           call retrieve_one_userid (privileged, caller_userid, userid_array (1), code);
 711           do userid_count = 2 repeat (userid_count + 1) while (code = 0);
 712                call retrieve_another_userid (privileged, caller_userid, userid_array (userid_count), code);
 713           end;
 714           if code ^= inquire_et_$no_entry
 715           then do;                                          /* Don't report error if we just ran out */
 716                     P_code = code;
 717                     call cleanup_proc ();
 718                     return;
 719                end;
 720           code = 0;                                         /* Don't leave code floating around */
 721 
 722           call unlock_db (code);
 723           if code ^= 0
 724           then do;
 725                     call cleanup_proc ();
 726                     return;
 727                end;
 728 
 729           P_userid_count, userid_count = userid_count - 2;  /* make up for the do variable overshoot */
 730           if area_ptr ^= null ()
 731           then do;
 732                     allocate userid_array in (user_area) set (P_userids_ptr);
 733                     P_userids_ptr -> userid_array = userid_array;
 734                end;
 735 
 736           call cleanup_proc ();
 737           return;
 738 ^L
 739 /*** Delete the specified entry from the database ***/
 740 delete_entry:
 741           entry (P_code);
 742 
 743           privileged = "0"b;
 744           go to dle_JOIN;
 745 
 746 priv_delete_entry:
 747           entry (P_userid, P_code);
 748 
 749           privileged = "1"b;
 750 
 751 dle_JOIN:
 752           on cleanup call cleanup_proc ();
 753           call start_up (code);
 754           if code ^= 0 then do;
 755                P_code = code;
 756                return;
 757           end;
 758 
 759                     P_code = 0;                                       /* Don't screw him */
 760 
 761           if privileged
 762           then userid = P_userid;
 763           else userid = rtrim (caller_userid);
 764           if userid = ""
 765           then userid = rtrim (caller_userid);
 766 
 767           call lock_db_write (code);
 768           if code ^= 0
 769           then do;
 770                     P_code = code;
 771                     call cleanup_proc ();
 772                     return;
 773                end;
 774 
 775           call delete_db_entry (userid, code);
 776           if code ^= 0
 777           then do;
 778                     P_code = code;
 779                     call cleanup_proc ();
 780                     return;
 781                end;
 782 
 783           call unlock_db (P_code);
 784 
 785           call cleanup_proc ();
 786           return;
 787 ^L
 788 /*
 789 set_all:
 790      entry (P_field_names_ptr, P_field_values_ptr, P_privacy_names_ptr, P_privacy_flags_ptr, P_entry_privacy, P_code);
 791 
 792           dcl     P_privacy_names_ptr    ptr;
 793           dcl     P_entry_privacy        bit (1) varying;
 794           privileged = "0"b;
 795           go to sa_JOIN;
 796 
 797 priv_set_all:
 798      entry (P_userid, P_field_names_ptr, P_field_values_ptr, P_privacy_names_ptr, P_privacy_flags_ptr, P_entry_privacy,
 799           P_code);
 800 
 801           privileged = "1"b;
 802 
 803 sa_JOIN:
 804           on cleanup call cleanup_proc ();
 805           call start_up (code);
 806           if code ^= 0
 807           then do;
 808                     P_code = code;
 809                     return;
 810                end;
 811 */
 812 /*******************/
 813           /*** FINISH THIS ***/
 814 /*******************/
 815 ^L
 816           /*** Internal subroutines ***/
 817 
 818           /*** Initializes various common stuff for all the entries. ***/
 819           /*** Currently makes sure the database is open, initializes
 820      caller_userid, and sets validation level. ***/
 821           /*** Plans: logging (will probably require calling sequence change).
 822             cleaning up database. ***/
 823 start_up:
 824      proc (P_code);
 825 
 826           dcl     P_code                 fixed bin (35);
 827 
 828           dcl     code                   fixed bin (35) init (0);
 829           dcl     user_info_$whoami      entry (char (*));
 830           dcl     first_time             bit (1) internal static init ("1"b);
 831           dcl     open_switch            bit (1);
 832 
 833           open_switch = "1"b;
 834           go to start_up_JOIN;
 835 
 836 start_up_no_open:
 837      entry (P_code);
 838 
 839           open_switch = "0"b;
 840 
 841 start_up_JOIN:
 842           user_ring = hcs_$level_get ();                    /* Validation level is still outer ring */
 843           inner_ring = get_ring_ ();                        /* This gets our hardware ring of execution */
 844           call hcs_$level_set (inner_ring);                 /* Now copy into validation level */
 845 
 846           unlock_on_cleanup = ^database_locked;
 847 
 848           if open_switch
 849           then do;                                          /* If caller wants to open */
 850                     call open_database (code);              /* Make sure database open */
 851                     if code ^= 0
 852                     then do;
 853                               P_code = code;
 854                               return;
 855                          end;
 856                end;
 857           if first_time                                     /* Only need to do this stuff once per process */
 858           then do;
 859                     call user_info_$whoami (caller_userid);
 860                     call add_epilogue_handler_ (close_db, P_code);
 861                                                             /* Clean up later */
 862 
 863                     first_time = "0"b;
 864                end;
 865 
 866           return;
 867 
 868 cleanup_proc:
 869      entry ();
 870 
 871           if unlock_on_cleanup
 872           then call unlock_db ((0));
 873           if temp_seg_ptr ^= null ()
 874           then call release_temp_segment_ (whoami, temp_seg_ptr, (0));
 875           call hcs_$level_set (user_ring);
 876 
 877           return;
 878 
 879      end start_up;
 880 
 881 
 882           /*** Routine to open the Inquire database when first referenced in a process.
 883      Sets the static variable inquire_dbi to the MRDS database_index.
 884           Also initializes various variables. ***/
 885 open_database:
 886      proc (P_code);
 887 
 888           dcl     P_code                 fixed bin (35);
 889 
 890           dcl     database_open          bit (1) static internal init ("0"b);
 891           dcl     inquire_dbi            fixed bin (35) static external;
 892                                                             /* Used to reference the Inquire database in MRDS calls */
 893 
 894           if database_open
 895           then return;
 896 
 897           call inquire_lock_$init (code);
 898           if code ^= 0
 899           then do;
 900                     P_code = code;
 901                     return;
 902                end;
 903 
 904           call dsl_$open (inquire_data_$db_path, inquire_dbi, UPDATE, code);
 905           if code ^= 0
 906           then do;
 907                     P_code = convert_open_code (code);
 908                end;
 909           else do;
 910                     database_open = "1"b;
 911                end;
 912 
 913           return;
 914 
 915 close_database:
 916      entry (P_code);
 917 
 918           if ^database_open
 919           then do;
 920                     P_code = inquire_et_$not_open;
 921                     return;
 922                end;
 923           call dsl_$close (inquire_dbi, P_code);
 924           database_open = "0"b;
 925           return;
 926 
 927      end open_database;
 928 ^L
 929           /*** Routine to convert field names into field numbers,
 930      and check that they are valid ***/
 931 convert_field_names:
 932      proc (bad_field);
 933 
 934           dcl     fn                     char (32);         /* Local to hold current field name */
 935           dcl     bad_field              fixed bin;         /* The field we lost on */
 936 
 937           do i = 1 to inq_field_names.name_count;
 938                fn = inq_field_names.name (i);
 939 
 940 /* Linear search for now */
 941                do j = 1 to inquire_data_$field_count;
 942                     if fn = known_field_names (j)
 943                     then do;
 944                               field_numbers (i) = j;
 945                               go to CFN_next_name;
 946                          end;
 947                end;
 948 
 949                /*** If we get here, then it couldn't find the name ***/
 950                bad_field = i;
 951                return;
 952 
 953 CFN_next_name:
 954           end;
 955           /*** outer do loop ***/
 956 
 957           bad_field = 0;
 958           return;
 959      end convert_field_names;
 960 ^L
 961           /*** Add another piece of the Inquire structure from data
 962      returned by MRDS ***/
 963 fill_work_structure:
 964      proc ();
 965 
 966           dcl     check                  bit (1);
 967 
 968           check = "0"b;
 969           go to FWS_join;
 970 
 971 fill_work_structure_check:
 972      entry ();
 973 
 974           check = "1"b;
 975 
 976 FWS_join:
 977           if inquire_data_array.private_entry & check
 978           then return;                                      /* Don't even acknowledge the entry */
 979 
 980           inq_field_values.entry_count, inq_fv_size = inq_field_values.entry_count + 1;
 981           do i = 1 to inq_field_values.value_count;
 982                if inquire_data_array.private (field_numbers (i)) & check
 983                then inq_field_values.entry (inq_field_values.entry_count).value (i) = "";
 984                                                             /* Return empty for private field, when check flag is true */
 985                else inq_field_values.entry (inq_field_values.entry_count).value (i) =
 986                          inquire_data_array.contents (field_numbers (i));
 987           end;
 988 
 989           return;
 990      end fill_work_structure;
 991 ^L
 992 fill_privacy_structure:
 993      proc ();
 994 
 995           do i = 1 to inq_field_privacies.value_count;
 996                inq_field_privacies.value (i) = inquire_data_array.private (field_numbers (i));
 997           end;
 998 
 999           return;
1000      end fill_privacy_structure;
1001 ^L
1002           /*** Come up with a MRDS select expression given the name of a field to key on ***/
1003 create_sel_exp:
1004      proc (P_field_name) returns (char (*));
1005 
1006           dcl     P_field_name           char (*);
1007 
1008           return ("-range (U user) -select U -where U." || P_field_name || " = .V.");
1009      end create_sel_exp;
1010 ^L
1011           /*** Retrieve the entry given a key with a specified value */
1012           /*** Assumes that the database is locked. ***/
1013 retrieve_entry:
1014      proc (P_key_name, P_key_value, P_code);
1015 
1016           dcl     P_key_name             char (*);
1017           dcl     P_key_value            char (200) varying;
1018           dcl     P_code                 fixed bin (35);
1019           dcl     inquire_dbi            fixed bin (35) static external;
1020                                                             /* Used to reference the Inquire database in MRDS calls */
1021 
1022           call dsl_$retrieve (inquire_dbi, create_sel_exp (P_key_name), P_key_value, inquire_data, code);
1023                                                             /* Get stuff */
1024           if code ^= 0
1025           then P_code = convert_retrieval_code (code);      /* What does it mean? */
1026           retrieved_userid = inquire_data.userid;
1027           return;
1028 
1029      end;
1030 ^L
1031           /*** Keep retrieving entries */
1032 retrieve_another:
1033      proc (P_code);
1034 
1035           dcl     P_code                 fixed bin (35);
1036           dcl     inquire_dbi            fixed bin (35) static external;
1037                                                             /* Used to reference the Inquire database in MRDS calls */
1038 
1039           call dsl_$retrieve (inquire_dbi, "-another", inquire_data, code);
1040                                                             /* Get stuff */
1041           if code ^= 0
1042           then P_code = convert_retrieval_code (code);      /* What does it mean? */
1043           if P_code = 0 & code ^= 0
1044           then P_code = code;                               /* Return the code from dl_scope only if retrieve worked */
1045           retrieved_userid = inquire_data.userid;
1046           return;
1047 
1048      end;
1049 ^L
1050           /*** Retrieve the first userid that is accessible to the caller ***/
1051 retrieve_one_userid:
1052      proc (P_priv, P_caller, P_userid, P_code);
1053 
1054           dcl     P_priv                 bit (1);
1055           dcl     P_caller               char (*);
1056           dcl     P_userid               char (*) varying;
1057           dcl     P_code                 fixed bin (35);
1058 
1059           dcl     inquire_dbi            fixed bin external;
1060           dcl     code                   fixed bin (35);
1061           dcl     sel_exp                char (100);
1062 
1063           if P_priv
1064           then call dsl_$retrieve (inquire_dbi, "-range (u user) -select u.userid", P_userid, code);
1065           else call dsl_$retrieve (inquire_dbi,
1066                     "-range (u user) -select u.userid -where ((u.userid = .V.) | (u.private_flag = ""0""b))",
1067                     rtrim (P_caller), P_userid, code);
1068 
1069           go to rou_DONE;
1070 
1071           /*** Must be called after the above entry ***/
1072 retrieve_another_userid:
1073      entry (P_priv, P_caller, P_userid, P_code);
1074 
1075           call dsl_$retrieve (inquire_dbi, "-another", P_userid, code);
1076 
1077 rou_DONE:
1078           P_code = convert_retrieval_code (code);
1079           return;
1080 
1081      end retrieve_one_userid;
1082 
1083           /*** Modify some fields in an entry, given a key and key value */
1084 modify_entry:
1085      proc (P_userid, P_code);
1086 
1087           dcl     P_userid               char (200) varying;
1088           dcl     P_code                 fixed bin (35);
1089           dcl     s_code                 fixed bin (35);
1090           dcl     inquire_dbi            fixed bin (35) static external;
1091                                                             /* Used to reference the Inquire database in MRDS calls */
1092 
1093           call dsl_$retrieve (inquire_dbi, create_sel_exp ("userid"), P_userid, inquire_data, s_code);
1094           if s_code = mrds_error_$tuple_not_found
1095           then call fill_new_entry (P_userid, P_code);
1096           else if s_code = 0
1097           then call fill_old_entry (P_userid, P_code);
1098           else P_code = convert_retrieval_code (s_code);
1099 ^L
1100           /*** Create a new Inquire entry, and fill in the fields */
1101 fill_new_entry:
1102      proc (P_userid, P_code);
1103 
1104           dcl     P_userid               char (200) varying;
1105           dcl     P_code                 fixed bin (35);
1106 
1107           do i = 1 to inquire_data_$field_count;            /* Initialize the entry */
1108                inquire_data_array.fields (i).contents = "";
1109                inquire_data_array.fields (i).private = "0"b;/* Default to non-fascist fields */
1110           end;
1111           inquire_data.private_flag = "1"b;                 /* but fascist entry */
1112           do i = 1 to inq_field_names.name_count;
1113                if field_numbers (i) = 1                     /* Trying to set userid */
1114                then do;
1115                          P_code = inquire_et_$cant_set_userid;
1116                          return;
1117                     end;
1118                inquire_data_array.fields (field_numbers (i)).contents = inq_field_values.entry (1).value (i);
1119                                                             /* Copy in the fields */
1120           end;
1121           inquire_data.userid = P_userid;
1122           call dsl_$store (inquire_dbi, "user", inquire_data, code);
1123           if code ^= 0
1124           then P_code = convert_store_code (code);
1125           return;
1126 
1127           /*** Fill in the given fields of an existing Inquire entry */
1128 fill_old_entry:
1129      entry (P_userid, P_code);
1130 
1131           do i = 1 to inq_field_names.name_count;
1132                if field_numbers (i) = 1                     /* Trying to set userid */
1133                then do;
1134                          P_code = inquire_et_$cant_set_userid;
1135                          return;
1136                     end;
1137                inquire_data_array.fields (field_numbers (i)).contents = inq_field_values.entry (1).value (i);
1138                                                             /* Copy in the fields */
1139           end;
1140           inquire_data.userid = P_userid;
1141           call dsl_$delete (inquire_dbi, create_sel_exp ("userid"), P_userid, code);
1142                                                             /* Delete, so we can store the entry anew */
1143           if code ^= 0
1144           then do;
1145                     P_code = convert_delete_code (code);
1146                     return;
1147                end;
1148           call dsl_$store (inquire_dbi, "user", inquire_data, code);
1149           if code ^= 0
1150           then P_code = convert_store_code (code);
1151           return;
1152 
1153 
1154      end fill_new_entry;
1155 
1156      end modify_entry;
1157 ^L
1158 /*** Delete an entry out of the database given the userid */
1159 delete_db_entry:
1160           proc (P_userid, P_code);
1161 
1162           dcl P_userid                            char (200) varying;
1163           dcl P_code                              fixed bin (35);
1164           dcl s_code                              fixed bin (35);
1165           dcl inquire_dbi               fixed bin (35) static external;
1166 
1167           call dsl_$delete (inquire_dbi, create_sel_exp ("userid"), P_userid, s_code);
1168           if s_code ^= 0 then P_code = convert_retrieval_code (s_code);
1169           else P_code = 0;
1170 
1171           return;
1172      end;
1173 
1174 ^L        /*** Modify some privacy flags in an entry, given a key value */
1175 modify_entry_privacy:
1176      proc (P_userid, P_code);
1177 
1178           dcl     P_userid               char (200) varying;
1179           dcl     P_code                 fixed bin (35);
1180           dcl     s_code                 fixed bin (35);
1181           dcl     inquire_dbi            fixed bin (35) static external;
1182                                                             /* Used to reference the Inquire database in MRDS calls */
1183 
1184           call dsl_$retrieve (inquire_dbi, create_sel_exp ("userid"), P_userid, inquire_data, s_code);
1185           if s_code = mrds_error_$tuple_not_found
1186           then call fill_new_entry (P_userid, P_code);
1187           else if s_code = 0
1188           then call fill_old_entry (P_userid, P_code);
1189           else P_code = convert_retrieval_code (s_code);
1190 ^L
1191           /*** Create a new Inquire entry, and fill in the privacy flags */
1192 fill_new_entry:
1193      proc (P_userid, P_code);
1194 
1195           dcl     P_userid               char (200) varying;
1196           dcl     P_code                 fixed bin (35);
1197 
1198           do i = 1 to inquire_data_$field_count;            /* Initialize the entry */
1199                inquire_data_array.fields (i).contents = "";
1200                inquire_data_array.fields (i).private = "0"b;/* Default to non-fascist fields */
1201           end;
1202           inquire_data.private_flag = "1"b;                 /* but fascist entry */
1203           do i = 1 to inq_field_names.name_count;
1204                inquire_data_array.fields (field_numbers (i)).private = inq_field_privacies.value (i);
1205                                                             /* Copy in the fields */
1206           end;
1207           inquire_data.userid = P_userid;
1208           call dsl_$store (inquire_dbi, "user", inquire_data, code);
1209           if code ^= 0
1210           then P_code = convert_store_code (code);
1211           return;
1212 
1213           /*** Fill in the given privacy flags of an existing Inquire entry */
1214 fill_old_entry:
1215      entry (P_userid, P_code);
1216 
1217           do i = 1 to inq_field_names.name_count;
1218                inquire_data_array.fields (field_numbers (i)).private = inq_field_privacies.value (i);
1219                                                             /* Copy in the fields */
1220           end;
1221           call dsl_$delete (inquire_dbi, create_sel_exp ("userid"), P_userid, code);
1222                                                             /* Delete, so we can store the entry anew */
1223           if code ^= 0
1224           then do;
1225                     P_code = convert_delete_code (code);
1226                     return;
1227                end;
1228           call dsl_$store (inquire_dbi, "user", inquire_data, code);
1229           if code ^= 0
1230           then P_code = convert_store_code (code);
1231           return;
1232 
1233 
1234      end fill_new_entry;
1235 
1236      end modify_entry_privacy;
1237 ^L
1238           /*** Modify the global privacy flag of an entry, given a key value */
1239 modify_private_entry_flag:
1240      proc (P_userid, P_privacy_flag, P_code);
1241 
1242           dcl     P_userid               char (200) varying;
1243           dcl     P_code                 fixed bin (35);
1244           dcl     P_privacy_flag         bit (1);
1245           dcl     s_code                 fixed bin (35);
1246           dcl     inquire_dbi            fixed bin (35) static external;
1247                                                             /* Used to reference the Inquire database in MRDS calls */
1248 
1249           call dsl_$modify (inquire_dbi, "-range (U user) -select U.private_flag -where U.userid = .V.", P_userid,
1250                P_privacy_flag, s_code);
1251           if s_code = mrds_error_$tuple_not_found
1252           then call fill_new_entry (P_userid, P_privacy_flag, P_code);
1253           else P_code = convert_retrieval_code (s_code);
1254 
1255           /*** Create a new Inquire entry, and fill in the privacy flag */
1256 fill_new_entry:
1257      proc (P_userid, P_privacy_flag, P_code);
1258 
1259           dcl     P_userid               char (200) varying;
1260           dcl     P_privacy_flag         bit (1);
1261           dcl     P_code                 fixed bin (35);
1262 
1263           do i = 1 to inquire_data_$field_count;            /* Initialize the entry */
1264                inquire_data_array.fields (i).contents = "";
1265                inquire_data_array.fields (i).private = "0"b;/* Default to non-fascist fields */
1266           end;
1267           inquire_data.private_flag = P_privacy_flag;       /* Install the requested privacy flag */
1268 
1269           inquire_data.userid = P_userid;
1270           call dsl_$store (inquire_dbi, "user", inquire_data, code);
1271           if code ^= 0
1272           then P_code = convert_store_code (code);
1273           return;
1274 
1275      end fill_new_entry;
1276 
1277      end modify_private_entry_flag;
1278 ^L
1279           /*** Come up with a good error code based upon the result of a dsl_$retrieve ***/
1280 convert_retrieval_code:
1281      proc (P_code) returns (fixed bin (35));
1282 
1283           dcl     P_code                 fixed bin (35);
1284 
1285           if P_code = mrds_error_$tuple_not_found
1286           then return (inquire_et_$no_entry);
1287           else return (P_code);
1288 
1289 convert_delete_code:
1290      entry (P_code) returns (fixed bin (35));
1291 
1292           if P_code = mrds_error_$tuple_not_found
1293           then return (inquire_et_$int_error_no_entry);
1294           else return (P_code);
1295 
1296 convert_store_code:
1297      entry (P_code) returns (fixed bin (35));
1298 
1299           if P_code = mrds_error_$dup_key
1300           then return (inquire_et_$int_error_dup_key);
1301           else return (P_code);
1302 
1303 convert_open_code:
1304      entry (P_code) returns (fixed bin (35));
1305 
1306           return (P_code);
1307 
1308      end convert_retrieval_code;
1309 
1310 lock_db_read:
1311      proc (P_code);
1312 
1313           dcl     P_code                 fixed bin (35);
1314           dcl     writing                bit (1);
1315           dcl     code                   fixed bin (35) init (0);
1316           dcl     inquire_dbi            fixed bin (35) static external;
1317                                                             /* Used to reference the Inquire database in MRDS calls */
1318 
1319           writing = "0"b;
1320           goto ldb_JOIN;
1321 
1322 lock_db_write:
1323      entry (P_code);
1324 
1325           writing = "1"b;
1326 
1327 ldb_JOIN:
1328           if database_locked
1329           then do;                                          /* Don't allow recursive calls while locked,
1330                                                                as the database could be inconsistent
1331                                                                (and my locking scheme will lose). */
1332                     P_code = inquire_et_$bad_recursion;
1333                     return;
1334                end;
1335 
1336           database_locked = "1"b;
1337 
1338           /*** This is a necessary grossness.  MRDS doesn't implement
1339                its locking properly, so it loses in the inner ring if
1340                someone else has the lock.  So I am using my own lock,
1341                so that the MRDS locks never interfere. ***/
1342 
1343           call inquire_lock_$lock (writing, code);
1344           if code ^= 0
1345           then do;
1346                     database_locked = "0"b;
1347                     P_code = code;
1348                     return;
1349                end;
1350 
1351 /* Now do MRDS locking, which should generally succeed (without waiting) */
1352           if writing
1353           then call dsl_$set_scope (inquire_dbi, inquire_data_$rel_name, ALL_OPS, ALL_OPS, 0, code);
1354           else call dsl_$set_scope (inquire_dbi, inquire_data_$rel_name, READ_ATTR, UPDATE_OPS, 0, code);
1355           if code ^= 0
1356           then do;
1357                     call inquire_lock_$unlock ((0));        /* Unlock our lock */
1358                     if code = mrds_error_$scope_not_empty   /* Recursive call while DB locked */
1359                     then P_code = inquire_et_$bad_recursion;
1360                     else do;
1361                               database_locked = "0"b;
1362                               if code = mrds_error_$db_busy /* Could not set scope in time */
1363                               then P_code = inquire_et_$int_error_db_busy;
1364                               else P_code = code;
1365                          end;
1366                     return;
1367                end;
1368 
1369           return;
1370 
1371      end lock_db_read;
1372 
1373 unlock_db:
1374      proc (P_code);
1375 
1376           dcl     P_code                 fixed bin (35);
1377           dcl     inquire_dbi            fixed bin (35) static external;
1378           dcl     (permit, prevent)      fixed bin;         /* Used to reference the Inquire database in MRDS calls */
1379 
1380           P_code = 0;
1381           if database_locked
1382           then do;
1383                     call dsl_$get_scope (inquire_dbi, inquire_data_$rel_name, permit, prevent, (0), (0));
1384                     call dsl_$dl_scope (inquire_dbi, inquire_data_$rel_name, permit, prevent, P_code);
1385                     call inquire_lock_$unlock (P_code);
1386                     database_locked = "0"b;
1387                end;
1388 
1389           return;
1390      end unlock_db;
1391 
1392      end inquire_r3_;