?? RIGHT := 110 ??
?? NEWTITLE := 'SCL and FS Test harnesses' ??
MODULE clm$test_harness;
*copyc clh$test_harness
*copyc clc$compiling_for_test_harness
*copyc fsc$compiling_for_test_harness

?? NEWTITLE := 'Global Declarations', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc oss$job_paged_literal
*copyc ost$heap
?? POP ??
*copyc amp$#copy_file
*copyc amp$#get_segment_pointer
*copyc amp$#open
*copyc amp$change_file_attributes
*copyc amp$close
*copyc amp$open
*copyc amp$put_next
*copyc avp$get_set_name
*copyc clp$interpret_commands
*copyc clp$pop_utility
*copyc clp$push_utility
*copyc clp$scan_command_file
*copyc fsv$test_harness_cmnds
*copyc fsv$test_harness_fnctns
*copyc jmp$get_attribute_defaults
*copyc osp$disestablish_cond_handler
*copyc osp$establish_condition_handler
*copyc osp$set_status_from_condition
*copyc pfp$define_master_catalog
*copyc pfp$overhaul_set
*copyc pmp$continue_to_cause
*copyc pmp$get_user_identification
*copyc rmp$request_terminal


  PROCEDURE [XREF] display
    (    display_line: string ( * <= 256));


  PROCEDURE [XREF] display_status
    (    status: ost$status);


  PROCEDURE [XREF] set_current_user_id;


  PROCEDURE [XREF] setup_job_pointers;


  PROCEDURE [XREF] setup_job_table_entry
    (    job_id: integer);



  VAR
    logging_out: [XREF] pmt$condition_name;

  ?IF clc$compiling_for_test_harness THEN

    VAR
      exiting: [XREF] pmt$condition_name;

    ?IF fsc$compiling_for_test_harness THEN

      VAR
        global_system_administrator: [XREF] boolean,
        global_family_administrator: [XREF] boolean,
        last_real_file_name: [XREF] amt$local_file_name;

    ?IFEND
  ?IFEND
?? TITLE := 'Stubbed variables', EJECT ??

  VAR
    osv$task_private_heap: [XDCL] ^ost$heap,
    osv$task_shared_heap: [XDCL] ^ost$heap;

  ?IF fsc$compiling_for_test_harness THEN

    VAR
      osv$mainframe_pageable_heap: [XDCL] ^ost$heap,
      osv$job_pageable_heap: [XDCL] ^ost$heap;

    ?IF NOT clc$compiling_for_test_harness THEN

      VAR
        userbam_utility_name: [XDCL] ost$name := 'USERBAM                        ';

    ?IFEND
  ?IFEND

?? TITLE := 'SCL test harness', EJECT ??
{                         **********************
{                         ** SCL TEST HARNESS **
{                         **********************

  ?IF clc$compiling_for_test_harness THEN

    PROCEDURE [XDCL] clp$test_harness
      (    ignore_parameter_list: clt$parameter_list;
       VAR status: ost$status);

?? NEWTITLE := 'abort_handler', EJECT ??

      PROCEDURE abort_handler
        (    condition: pmt$condition;
             condition_descriptor: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          exit_status: ^ost$status;

        IF (condition.selector = pmc$user_defined_condition) AND
              ((condition.user_condition_name = exiting) OR (condition.user_condition_name = logging_out))
              THEN
          exit_status := condition_descriptor;
          status := exit_status^;
          EXIT clp$test_harness;
        IFEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND abort_handler;
?? OLDTITLE, EJECT ??
      ?IF fsc$compiling_for_test_harness THEN

        VAR
          terminal_null_attribute: array [1 .. 1] of ift$connection_attribute,
          command_file: amt$local_file_name,
          charge_id: pft$charge_id,
          default_attribute_results: ^jmt$default_attribute_results,
          user_id: ost$user_identification,
          local_status: ost$status,
          set_name: stt$set_name;

      ?IFEND

      osp$establish_condition_handler (^abort_handler, FALSE);

      create_heap ('OSV$TASK_PRIVATE_HEAP          ', osv$task_private_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      create_heap ('OSV$TASK_SHARED_HEAP           ', osv$task_shared_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      setup_job_table_entry (1);

      ?IF fsc$compiling_for_test_harness THEN
        create_heap ('OSV$MAINFRAME_PAGEABLE_HEAP    ', osv$mainframe_pageable_heap, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        create_heap ('OSV$JOB_PAGEABLE_HEAP          ', osv$job_pageable_heap, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;

        setup_job_pointers;
        global_system_administrator := TRUE;
        global_family_administrator := FALSE;

        bring_in_command_library ('OSF$COMMAND_LIBRARY            ', 'OSF$COMMAND_LIBRARY            ');

        set_current_user_id;
        pmp$get_user_identification (user_id, status);
        avp$get_set_name (user_id.family, set_name, status);

        pfp$overhaul_set (set_name, $pft$set_overhaul_choices [], status);

        charge_id.account := '  ';
        charge_id.project := ' ';
        PUSH default_attribute_results: [1 .. 1];
        default_attribute_results^ [1].key := jmc$login_family;
        jmp$get_attribute_defaults (jmc$interactive_connected, default_attribute_results, status);
        pfp$define_master_catalog (set_name, default_attribute_results^ [1].login_family,
              user_id.user, charge_id, status);
        pfp$define_master_catalog (set_name, '$SYSTEM                        ',
              '$SYSTEM                        ', charge_id, status);

        global_system_administrator := FALSE;
        global_family_administrator := FALSE;

        terminal_null_attribute [1].key := ifc$null_connection_attribute;

        display (' requesting terminal: input, output, command');
        rmp$request_terminal ('INPUT                          ', NIL, terminal_null_attribute, status);
        display_status (status);

        rmp$request_terminal ('OUTPUT                         ', NIL, terminal_null_attribute, status);
        display_status (status);

        rmp$request_terminal ('COMMAND                        ', NIL, terminal_null_attribute, status);
        display_status (status);

        display (' interpret commands');
      ?IFEND

      clp$interpret_commands;

      osp$disestablish_cond_handler;

    PROCEND clp$test_harness;
  ?IFEND
?? TITLE := 'FS test harness', EJECT ??
{                         **********************
{                         ** FS TEST HARNESS. **
{                         **********************

  ?IF fsc$compiling_for_test_harness AND (NOT clc$compiling_for_test_harness) THEN

    PROCEDURE [XDCL] fsp$test_harness
      (    ignore_parameter_list: clt$parameter_list;
       VAR status: ost$status);

?? NEWTITLE := 'stub_abort_handler', EJECT ??

      PROCEDURE stub_abort_handler
        (    condition: pmt$condition;
             condition_information: ^pmt$condition_information;
             save_area: ^ost$stack_frame_save_area;
         VAR handler_status: ost$status);

        VAR
          condition_status,
          construction_status: ost$status;

        handler_status.normal := TRUE;

{ DISPLAY THE REASON FOR THE CONDITION

        display (' Condition occurred in stub_abort_handlers');
        osp$set_status_from_condition (amc$access_method_id, condition, save_area, condition_status,
              construction_status);
        IF construction_status.normal THEN
          display_status (condition_status);
        ELSE
          display_status (construction_status);
        IFEND;
        CASE condition.selector OF

        = pmc$user_defined_condition =
          IF condition.user_condition_name = logging_out THEN
            EXIT fsp$test_harness;
          IFEND;

        = ifc$interactive_condition =
          display (' interactive condition');
          display (' Continue to cause - execute standard procedure');
          status.normal := TRUE;

        ELSE
        CASEND;

        pmp$continue_to_cause (pmc$execute_standard_procedure, handler_status);

      PROCEND stub_abort_handler;
?? OLDTITLE, EJECT ??

      VAR
        command_file: amt$local_file_name,
        local_status: ost$status;

      display (' Welcome to user bam');
      osp$establish_condition_handler (^stub_abort_handler, FALSE);

      create_heap ('OSV$TASK_PRIVATE_HEAP          ', osv$task_private_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      create_heap ('OSV$TASK_SHARED_HEAP           ', osv$task_shared_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      create_heap ('OSV$MAINFRAME_PAGEABLE_HEAP    ', osv$mainframe_pageable_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      create_heap ('OSV$JOB_PAGEABLE_HEAP          ', osv$job_pageable_heap, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      set_current_user_id;
      setup_job_pointers;
      setup_job_table_entry (1);

      clp$push_utility (userbam_utility_name, clc$global_command_search, fsv$test_harness_cmnds,
            fsv$test_harness_fnctns, status);
      IF status.normal THEN
        command_file := '$COMMAND';
        clp$scan_command_file (command_file, userbam_utility_name, 'UB', status);
        clp$pop_utility (local_status);
      IFEND;

      osp$disestablish_cond_handler;

    PROCEND fsp$test_harness;
  ?IFEND
?? TITLE := 'create_heap', EJECT ??

  PROCEDURE create_heap
    (    heap_file_name: amt$local_file_name;
     VAR heap_pointer: ^ost$heap;
     VAR status: ost$status);

    VAR
      file_identifier: amt$file_identifier,
      segment_pointer: amt$segment_pointer;

    amp$#open (heap_file_name, amc$segment, NIL, file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    amp$#get_segment_pointer (file_identifier, amc$cell_pointer, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    heap_pointer := segment_pointer.cell_pointer;
    RESET heap_pointer^;

  PROCEND create_heap;
?? TITLE := 'bring_in_command_library', EJECT ??

  ?IF clc$compiling_for_test_harness AND fsc$compiling_for_test_harness THEN

    PROCEDURE bring_in_command_library
      (    real_lfn: amt$local_file_name;
           userbam_lfn: amt$local_file_name);

      VAR
        status: ost$status,
        p_change_attributes: ^amt$file_attributes,
        wsa: ^cell,
        wsa_string: string (50),
        fid: amt$file_identifier,
        wsl: amt$working_storage_length,
        ba: amt$file_byte_address;

      display (' bringing in command library ');
      display (userbam_lfn);

{ first create the userbam file and put enough data in it so that
{ eoi is believable by command language.

      amp$open (userbam_lfn, amc$record, NIL, fid, status);
      IF NOT status.normal THEN
        display_status (status);
      IFEND;
      wsa_string := 'Garys kludge';
      wsa := ^wsa_string;
      amp$put_next (fid, wsa, 50, ba, status);
      amp$put_next (fid, wsa, 50, ba, status);
      amp$put_next (fid, wsa, 50, ba, status);
      amp$put_next (fid, wsa, 50, ba, status);
      amp$close (fid, status);

{ copy the data into the file

      display (' amp$#copy_file');
      amp$#copy_file (real_lfn, last_real_file_name, status);
      display_status (status);

{ chafa to make them believable as a command library

      PUSH p_change_attributes: [1 .. 2];
      p_change_attributes^ [1].key := amc$file_structure;
      p_change_attributes^ [1].file_structure := 'LIBRARY';
      p_change_attributes^ [2].key := amc$file_contents;
      p_change_attributes^ [2].file_contents := 'OBJECT';

      display (' chafa file ');
      amp$change_file_attributes (userbam_lfn, p_change_attributes, status);
      display_status (status);

    PROCEND bring_in_command_library;

  ?IFEND

MODEND clm$test_harness;
