?? RIGHT := 110 ??
?? NEWTITLE := 'INSTALL_SOFTWARE Utility: OCP$APPLY_OBJECT_CORRECTION Interface.' ??
MODULE ocm$apply_object_correction;
{ PURPOSE:
{   The module contains the interface to apply an object library correction.
{
{ DESIGN:
{  This compiled module resides in RAF$LIBRARY.
{
{  NOTES:
{
?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc rae$condition_codes
*copyc oct$metapatch_header
*copyc oct$move_items
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$return
*copyc amp$set_segment_eoi
*copyc fsp$close_file
*copyc fsp$open_file
*copyc ocp$apply_corrector
*copyc ocp$apply_move_items
*copyc ocp$build_first_intermediate_ol
*copyc ocp$checksum
*copyc ocp$copy
*copyc osp$append_status_file
*copyc osp$disestablish_cond_handler
*copyc osp$establish_block_exit_hndlr
*copyc osp$set_status_abnormal
*copyc pmp$get_unique_name
*copyc rap$open_file
?? OLDTITLE, NEWTITLE := '[XDCL] ocp$apply_object_correction', EJECT ??

{ PURPOSE:
{   This interface applys an object correction to the base file
{   and returns the result in the target file.
{
{ DESIGN:
{
{
{ NOTES:
{

  PROCEDURE [XDCL] ocp$apply_object_correction
    (    base_file: fst$file_reference;
         correction_file: fst$file_reference;
         target_file { output } : fst$file_reference;
     VAR status: ost$status);

    VAR
      attribute: array [1 .. 1] of fst$file_cycle_attribute,
      base_object_library: amt$segment_pointer,
      base_fid: amt$file_identifier,
      base_file_open: boolean,
      correction_fid: amt$file_identifier,
      correction_file_open: boolean,
      correction_sequence: amt$segment_pointer,
      corrector: ^SEQ ( * ),
      first_temp_fid: amt$file_identifier,
      first_temp_file: ost$name,
      first_temp_file_open: boolean,
      first_temp_object_library: amt$segment_pointer,
      ignore_status: ost$status,
      local_status: ost$status,
      metapatch: ^SEQ ( * ),
      metapatch_header: ^oct$metapatch_header,
      move_items: ^oct$move_items,
      new_checksum: integer,
      old_checksum: integer,
      predictor: ^SEQ ( * ),
      second_temp_fid: amt$file_identifier,
      second_temp_file: ost$name,
      second_temp_file_open: boolean,
      second_temp_object_library: amt$segment_pointer,
      target_object_library: amt$segment_pointer,
      target_fid: amt$file_identifier,
      target_file_open: boolean,
      write_attachment: array [1 .. 2] of fst$attachment_option;

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

{ PURPOSE:
{   This procedure cleans up when an abort situation occurs
{   within the block structure.
{
{ DESIGN:
{   Return any open files and delete any sequences.
{
{ NOTES:
{
{

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

      VAR
        ignore_status: ost$status;

      IF base_file_open THEN
        fsp$close_file (base_fid, ignore_status);
        base_file_open := FALSE;
      IFEND;

      IF target_file_open THEN
        fsp$close_file (target_fid, ignore_status);
        target_file_open := FALSE;
      IFEND;

      IF correction_file_open THEN
        fsp$close_file (correction_fid, ignore_status);
        correction_file_open := FALSE;
      IFEND;

      IF first_temp_file_open THEN
        fsp$close_file (first_temp_fid, ignore_status);
        first_temp_file_open := FALSE;
        amp$return(first_temp_file, ignore_status);
      IFEND;

      IF second_temp_file_open THEN
        fsp$close_file (second_temp_fid, ignore_status);
        second_temp_file_open := FALSE;
        amp$return(second_temp_file, ignore_status);
      IFEND;

    PROCEND abort_handler;

?? OLDTITLE, EJECT ??

    status.normal := TRUE;

    base_file_open := FALSE;
    target_file_open := FALSE;
    correction_file_open := FALSE;
    first_temp_file_open := FALSE;
    second_temp_file_open := FALSE;

    osp$establish_block_exit_hndlr (^abort_handler);

  /main/
    BEGIN

      rap$open_file (^base_file, amc$segment, fsc$read, FALSE, NIL, base_fid, base_file_open, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (base_fid, amc$sequence_pointer, base_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      rap$open_file (^correction_file, amc$segment, fsc$read, FALSE, NIL, correction_fid,
            correction_file_open, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (correction_fid, amc$sequence_pointer, correction_sequence, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      metapatch := correction_sequence.sequence_pointer;

      write_attachment [1].selector := fsc$access_and_share_modes;
      write_attachment [1].access_modes.selector := fsc$specific_access_modes;
      write_attachment [1].access_modes.value := $fst$file_access_options
            [fsc$read, fsc$shorten, fsc$append, fsc$modify];
      write_attachment [1].share_modes.selector := fsc$determine_from_access_modes;
      write_attachment [2].selector := fsc$create_file;
      write_attachment [2].create_file := TRUE;

      attribute [1].selector := fsc$file_contents_and_processor;
      attribute [1].file_contents := fsc$object_library;
      attribute [1].file_processor := fsc$unknown_processor;

      fsp$open_file (target_file, amc$segment, ^write_attachment, ^attribute, NIL, NIL, NIL, target_fid,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (target_fid, amc$sequence_pointer, target_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      pmp$get_unique_name (first_temp_file, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;

      fsp$open_file (first_temp_file, amc$segment, ^write_attachment, NIL, NIL, NIL, NIL, first_temp_fid,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      first_temp_file_open := TRUE;

      amp$get_segment_pointer (first_temp_fid, amc$sequence_pointer, first_temp_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      RESET metapatch;
      NEXT metapatch_header IN metapatch;
      IF metapatch_header = NIL THEN
        osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
        EXIT /main/;
      IFEND;

      old_checksum := ocp$checksum (base_object_library.sequence_pointer);

      IF old_checksum <> metapatch_header^.old_checksum THEN
        osp$set_status_abnormal ('RA', rae$corr_base_checksum_mismatch, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, base_file, status);
        EXIT /main/;
      IFEND;

      IF metapatch_header^.predictor_size > 0 THEN
        predictor := #PTR (metapatch_header^.predictor, metapatch^);
        RESET metapatch TO predictor;
        NEXT predictor: [[REP metapatch_header^.predictor_size OF cell]] IN metapatch;
        IF predictor = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
          RETURN;
        IFEND;

        ocp$build_first_intermediate_ol (predictor, base_object_library.sequence_pointer,
              first_temp_object_library.sequence_pointer, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      ELSE
        ocp$copy (base_object_library.sequence_pointer, first_temp_object_library.sequence_pointer, status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      pmp$get_unique_name (second_temp_file, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      fsp$open_file (second_temp_file, amc$segment, ^write_attachment, NIL, NIL, NIL, NIL, second_temp_fid,
            status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      second_temp_file_open := TRUE;

      amp$get_segment_pointer (second_temp_fid, amc$sequence_pointer, second_temp_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      IF metapatch_header^.number_of_move_items > 0 THEN
        move_items := #PTR (metapatch_header^.move_items, metapatch^);
        RESET metapatch TO move_items;
        NEXT move_items: [1 .. metapatch_header^.number_of_move_items] IN metapatch;
        IF move_items = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
          EXIT /main/;
        IFEND;

        ocp$apply_move_items (first_temp_object_library.sequence_pointer, move_items,
              metapatch_header^.number_of_move_items, second_temp_object_library.sequence_pointer);
      ELSE
        ocp$copy (first_temp_object_library.sequence_pointer, second_temp_object_library.sequence_pointer,
              status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      IF metapatch_header^.corrector_size > 0 THEN
        corrector := #PTR (metapatch_header^.corrector, metapatch^);
        RESET metapatch TO corrector;
        NEXT corrector: [[REP metapatch_header^.corrector_size OF cell]] IN metapatch;
        IF corrector = NIL THEN
          osp$set_status_abnormal ('RA', rae$accessed_beyond_segment, 'METAPATCH', status);
          EXIT /main/;
        IFEND;

        ocp$apply_corrector (corrector, second_temp_object_library.sequence_pointer,
              target_object_library.sequence_pointer);
      ELSE
        ocp$copy (second_temp_object_library.sequence_pointer, target_object_library.sequence_pointer,
              status);
        IF NOT status.normal THEN
          EXIT /main/;
        IFEND;
      IFEND;

      amp$set_segment_eoi (target_fid, target_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      fsp$close_file (target_fid, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;
      target_file_open := FALSE;

      rap$open_file (^target_file, amc$segment, fsc$read, FALSE, NIL, target_fid, target_file_open, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      amp$get_segment_pointer (target_fid, amc$sequence_pointer, target_object_library, status);
      IF NOT status.normal THEN
        EXIT /main/;
      IFEND;

      new_checksum := ocp$checksum (target_object_library.sequence_pointer);
      IF new_checksum <> metapatch_header^.new_checksum THEN
        osp$set_status_abnormal ('RA', rae$error_in_object_library, '', status);
        osp$append_status_file (osc$status_parameter_delimiter, correction_file, status);
        osp$append_status_file (osc$status_parameter_delimiter, base_file, status);
        EXIT /main/;
      IFEND;

    END /main/;

    IF base_file_open THEN
      fsp$close_file (base_fid, local_status);
      base_file_open := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF target_file_open THEN
      fsp$close_file (target_fid, local_status);
      target_file_open := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF correction_file_open THEN
      fsp$close_file (correction_fid, local_status);
      correction_file_open := FALSE;
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF first_temp_file_open THEN
      fsp$close_file (first_temp_fid, local_status);
      first_temp_file_open := FALSE;
      amp$return(first_temp_file, ignore_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

    IF second_temp_file_open THEN
      fsp$close_file (second_temp_fid, local_status);
      second_temp_file_open := FALSE;
      amp$return(second_temp_file, ignore_status);
      IF status.normal AND (NOT local_status.normal) THEN
        status := local_status;
      IFEND;
    IFEND;

   osp$disestablish_cond_handler;

  PROCEND ocp$apply_object_correction;
?? OLDTITLE ??
MODEND ocm$apply_object_correction;
