?? NEWTITLE := 'NOS/VE Job Scheduling : administer_profile' ??
MODULE jmm$administer_profile;

{ PURPOSE:
{   This module provides the routines to read and write a scheduling
{   profile.
{
{ DESIGN:
{   The scheduling profile is kept as a segment access file.  The file
{   is read and written as a sequence.  The file starts with a header
{   followed by all the objects then all the values for each object.
{   To provide for reasonable error detection, each item written to the
{   profile is preceeded by a string identifying its nature.  This string
{   is verified when reading the profile to ensure that the item is what
{   is expected.

?? NEWTITLE := 'Global Declarations Referenced by This Module', EJECT ??
?? PUSH (LISTEXT := ON) ??
*copyc jmc$job_management_id
*copyc jme$profile_errors
?? POP ??
*copyc amp$get_segment_pointer
*copyc amp$set_segment_eoi
*copyc fsp$close_file
*copyc fsp$open_file
*copyc jmp$close_system_profile
*copyc jmp$delete_attributes
*copyc jmp$delete_profile_cycle
*copyc jmp$open_system_profile
*copyc jmt$profile_header
*copyc jmt$profile_data
*copyc osp$append_status_file
*copyc osp$set_status_condition

*copyc clv$standard_files
*copyc jmv$object_definition
*copyc jmv$object_heap
*copyc jmv$the_profile
?? TITLE := 'Declarations for This Module', EJECT ??

  CONST
    bad_item_id = 'BADV',
    keyword_item_id = 'KEYW',
    value_item_id = 'VALU';

  TYPE
    item_header = record
      name: string (4),
      size: 0 .. 0ffffffff(16),
    recend;

  VAR
    required_attributes: [STATIC] array [1 .. 3] of
          fst$file_cycle_attribute := [[fsc$file_contents_and_processor,
          'SCHEDULING_PROFILE', 'ADMINISTER_SCHEDULING'],
          [fsc$file_organization, amc$byte_addressable],
          [fsc$record_type, amc$undefined]];

  VAR
    attribute_kind_id: [STATIC] array [jmt$object_attribute_kinds] of string
          (4) := ['TYPE', 'LIST', 'ELST', 'RNGE', 'NUMB', 'BOOL', 'NAME',
          'FILE', 'OBJR', 'DISP', '---C', '---D', 'EMPT', 'NONE', 'ALL ',
          'UNLM', 'UNSP', 'DFLT', 'SDFT'],
    old_keyword_to_new_keyword: [STATIC] array [12 .. 18] of
          jmt$object_attribute_kinds := [jmc$empty, jmc$none, jmc$all,
          jmc$unlimited, jmc$unspecified, jmc$default, jmc$system_default];

?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$read_profile', EJECT ??

{ PURPOSE:
{   This interface reads the profile from the specified file.

  PROCEDURE [XDCL] jmp$read_profile
    (    base_file: fst$file_reference;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      profile_file_identifier: amt$file_identifier,
      read_attachment: [STATIC] array [1 .. 2] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read]], [fsc$specific_share_modes, []]],
            [fsc$open_position, amc$open_at_boi]];

    fsp$open_file (base_file, amc$segment, ^read_attachment, NIL, NIL,
          ^required_attributes, NIL, profile_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    read_profile (profile_file_identifier, the_profile, status);
    IF NOT status.normal THEN
      osp$append_status_file (osc$status_parameter_delimiter, base_file,
            status);
    IFEND;

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

  PROCEND jmp$read_profile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$read_system_profile', EJECT ??

{ PURPOSE:
{   This interface reads the profile from the specified file.

  PROCEDURE [XDCL] jmp$read_system_profile
    (    profile_access_id: ost$binary_unique_name;
         cycle_number: jmt$system_profile_cycle_number;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      profile_file_identifier: amt$file_identifier;

    jmp$open_system_profile (profile_access_id, cycle_number,
          {open_for_write = } FALSE, ^required_attributes,
          profile_file_identifier, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

    read_profile (profile_file_identifier, the_profile, status);

    jmp$close_system_profile (profile_access_id, {detach_file} FALSE,
          profile_file_identifier, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND jmp$read_system_profile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$write_profile', EJECT ??

{ PURPOSE:
{   This interface opens and writes the profile to the specified file.

  PROCEDURE [XDCL] jmp$write_profile
    (    base_file: fst$file_reference;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      profile_file_identifier: amt$file_identifier,
      write_attachment: [STATIC] array [1 .. 3] of fst$attachment_option :=
            [[fsc$access_and_share_modes, [fsc$specific_access_modes,
            [fsc$read, fsc$append, fsc$modify, fsc$shorten]],
            [fsc$specific_share_modes, []]], [fsc$create_file, TRUE],
            [fsc$open_position, amc$open_at_boi]];

    status.normal := TRUE;
    IF base_file = clv$standard_files [clc$sf_null_file].path_handle_name THEN
      RETURN;
    IFEND;

    fsp$open_file (base_file, amc$segment, ^write_attachment, NIL,
          ^required_attributes, ^required_attributes, NIL,
          profile_file_identifier, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;

    write_profile (profile_file_identifier, the_profile, status);

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

  PROCEND jmp$write_profile;
?? OLDTITLE ??
?? NEWTITLE := '[XDCL] jmp$write_system_profile', EJECT ??

{ PURPOSE:
{   This interface opens and writes the profile to the specified cycle of the
{   system profile.

  PROCEDURE [XDCL] jmp$write_system_profile
    (    profile_access_id: ost$binary_unique_name;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      local_status: ost$status,
      profile_file_identifier: amt$file_identifier;

    jmp$open_system_profile (profile_access_id, { cycle_number =} 1,
          { open_for_write = } TRUE, ^required_attributes,
          profile_file_identifier, status);
    IF NOT status.normal THEN
      IF status.condition <> pfe$duplicate_cycle THEN
        RETURN;
      IFEND;
      jmp$delete_profile_cycle (profile_access_id, { cycle_number =} 1,
            local_status);
      IF NOT local_status.normal THEN
        RETURN;
      IFEND;
      jmp$open_system_profile (profile_access_id, { cycle_number =} 1,
            { open_for_write = } TRUE, ^required_attributes,
            profile_file_identifier, status);
      IF NOT status.normal THEN
        RETURN;
      IFEND;
    IFEND;

    write_profile (profile_file_identifier, the_profile, status);

    jmp$close_system_profile (profile_access_id, { Detach_file =} TRUE,
          profile_file_identifier, local_status);
    IF status.normal AND NOT local_status.normal THEN
      status := local_status;
    IFEND;

  PROCEND jmp$write_system_profile;
?? OLDTITLE ??
?? NEWTITLE := 'read_profile', EJECT ??

{ PURPOSE:
{   This interface reads the profile from the opened file.
{
{ DESIGN:
{   This routine reads the profile from the file in the same manner that
{   it was written.  The header is read first.  The all the object headers
{   are read.  Finally all the attributes for all the objects are read.
{
{ NOTES:
{   Consistancy checks are made for each item read that the item we expect
{   to read is in fact the next item.

  PROCEDURE read_profile
    (    profile_file_identifier: amt$file_identifier;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      profile_file: ^SEQ ( * ),
      profile_object_list: ^array [1 .. * ] of jmt$profile_object_reference;

?? NEWTITLE := 'read_attributes', EJECT ??

{ PURPOSE:
{   This routine reads attributes from the file.
{
{ DESIGN:
{   The routine reads the item header from the file and compares it with
{   what was expected.  As it reads the attributes from the file it also
{   compares them with the current attribute definition.  If the definition
{   is empty then the data is skipped.  The length of type attributes can
{   be different.  In any case the current definition length is used but
{   extra attributes in the file are skipped or extra attributes in the
{   current definition are set to empty so they will default properly.

    PROCEDURE read_attributes
      (    attribute_definition: jmt$profile_declaration;
       VAR attribute: jmt$object_attribute;
       VAR status: ost$status);

      VAR
        attribute_from_profile: ^jmt$object_attribute,
        file: ^fst$file_reference,
        i: integer,
        item: ^item_header,
        kind: jmt$object_attribute_kinds,
        name: ^ost$name,
        upper_bound: integer;

      status.normal := FALSE;

      IF attribute_definition.kind = jmc$empty THEN
        skip_attributes (status);
        RETURN;
      IFEND;

      NEXT item IN profile_file;
      IF item = NIL THEN
        RETURN;
      IFEND;

      NEXT attribute_from_profile IN profile_file;
      IF attribute_from_profile = NIL THEN
        RETURN;
      IFEND;

      IF item^.name = value_item_id THEN
        attribute := attribute_from_profile^;
        attribute.kind := attribute_definition.kind;

      ELSEIF item^.name = keyword_item_id THEN
        attribute.kind := old_keyword_to_new_keyword
              [$INTEGER (attribute_from_profile^.kind)];

      ELSE
        kind := jmc$type;
        WHILE (kind < jmc$system_default) AND
              (attribute_kind_id [kind] <> item^.name) DO
          kind := SUCC (kind);
        WHILEND;

        IF attribute_kind_id [kind] <> item^.name THEN
          RETURN;
        IFEND;

        CASE kind OF
        = jmc$type =
          IF kind <> attribute_definition.kind THEN
            RETURN;
          IFEND;

          upper_bound := UPPERBOUND (attribute_definition.declarations^);
          ALLOCATE attribute.attribute_list: [1 .. upper_bound] IN
                jmv$object_heap^;
          FOR i := 1 TO upper_bound DO
            attribute.attribute_list^ [i].kind := jmc$empty;
          FOREND;
          attribute.kind := kind;

          FOR i := 1 TO item^.size DO
            IF i > upper_bound THEN
              skip_attributes (status);
            ELSE
              read_attributes (attribute_definition.declarations^ [i]^,
                    attribute.attribute_list^ [i], status);
            IFEND;
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;

        = jmc$list, jmc$range, jmc$editable_list =
          IF kind <> attribute_definition.kind THEN
            RETURN;
          IFEND;

          upper_bound := item^.size;
          ALLOCATE attribute.attribute_list: [1 .. upper_bound] IN
                jmv$object_heap^;
          FOR i := 1 TO upper_bound DO
            attribute.attribute_list^ [i].kind := jmc$empty;
          FOREND;
          attribute.kind := kind;

          FOR i := 1 TO upper_bound DO
            read_attributes (attribute_definition.declarations^ [1]^,
                  attribute.attribute_list^ [i], status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;

        = jmc$name =
          IF attribute_definition.kind <> kind THEN
            RETURN;
          IFEND;

          NEXT name IN profile_file;
          IF name = NIL THEN
            RETURN;
          IFEND;

          ALLOCATE attribute.name IN jmv$object_heap^;
          attribute.kind := kind;
          attribute.name^ := name^;

        = jmc$file =
          IF kind <> attribute_definition.kind THEN
            RETURN;
          IFEND;

          NEXT file: [item^.size] IN profile_file;
          IF file = NIL THEN
            RETURN;
          IFEND;

          ALLOCATE attribute.file: [STRLENGTH (file^)] IN jmv$object_heap^;
          attribute.kind := kind;
          attribute.file^ := file^;

        = jmc$object =
          IF kind <> attribute_definition.kind THEN
            RETURN;
          IFEND;

          attribute.object_p := profile_object_list^
                [attribute_from_profile^.profile_object_index];
          attribute.object_p^.references := attribute.object_p^.references + 1;
          attribute.kind := kind;

        = jmc$number, jmc$boolean, jmc$dispatching_priority =
          attribute := attribute_from_profile^;
          attribute.kind := kind;

        = jmc$empty, jmc$none, jmc$all, jmc$unlimited, jmc$unspecified,
              jmc$default, jmc$system_default =
          attribute.kind := kind;
        CASEND;
      IFEND;
      status.normal := TRUE;
    PROCEND read_attributes;
?? TITLE := 'skip_attributes', EJECT ??

{ PURPOSE:
{   This routine skips attributes that no longer have meaning.
{
{ DESIGN:
{   If the definition of the profile has changed between now and the last
{   time the profile was written, then some attributes may no longer be used
{   This routine is used to skip this data when the file is read.

    PROCEDURE skip_attributes
      (VAR status: ost$status);

      VAR
        attribute_from_profile: ^jmt$object_attribute,
        file: ^fst$file_reference,
        i: integer,
        item: ^item_header,
        kind: jmt$object_attribute_kinds,
        name: ^ost$name;

      status.normal := FALSE;
      NEXT item IN profile_file;
      IF item = NIL THEN
        RETURN;
      IFEND;

      NEXT attribute_from_profile IN profile_file;
      IF attribute_from_profile = NIL THEN
        RETURN;
      IFEND;

      IF (item^.name = value_item_id) OR (item^.name = keyword_item_id) THEN

      ELSE
        kind := jmc$type;
        WHILE (kind < jmc$system_default) AND
              (attribute_kind_id [kind] <> item^.name) DO
          kind := SUCC (kind);
        WHILEND;

        IF attribute_kind_id [kind] <> item^.name THEN
          RETURN;
        IFEND;

        CASE kind OF
        = jmc$type, jmc$list, jmc$range, jmc$editable_list =
          FOR i := 1 TO item^.size DO
            skip_attributes (status);
            IF NOT status.normal THEN
              RETURN;
            IFEND;
          FOREND;

        = jmc$name =
          NEXT name IN profile_file;
          IF name = NIL THEN
            RETURN;
          IFEND;

        = jmc$file =
          NEXT file: [item^.size] IN profile_file;
          IF file = NIL THEN
            RETURN;
          IFEND;

        ELSE
        CASEND;
      IFEND;
      status.normal := TRUE;
    PROCEND skip_attributes;
?? OLDTITLE, EJECT ??

    VAR
      local_status: ost$status,
      segment_pointer: amt$segment_pointer;

    VAR
      i: integer,
      objects_on_profile: integer,
      object_kind: jmt$profile_object_kinds,
      header: ^jmt$profile_header,
      item: ^item_header,
      previous_object: jmt$profile_object_reference,
      the_object: jmt$profile_object_reference;

    objects_on_profile := 0;

    amp$get_segment_pointer (profile_file_identifier, amc$sequence_pointer,
          segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;
    RESET segment_pointer.sequence_pointer;
    profile_file := segment_pointer.sequence_pointer;

  /read_file/
    BEGIN

      NEXT header IN profile_file;
      IF header = NIL THEN
        EXIT /read_file/;
      IFEND;

      IF header^.version <> jmc$profile_version THEN
        EXIT /read_file/;
      IFEND;

      objects_on_profile := header^.object_count;

      PUSH profile_object_list: [1 .. objects_on_profile];
      FOR i := 1 TO objects_on_profile DO
        profile_object_list^ [i] := NIL;
      FOREND;

      FOR i := 1 TO objects_on_profile DO
        NEXT item IN profile_file;
        IF item = NIL THEN
          EXIT /read_file/;
        IFEND;

        IF item^.name <> 'OBJI' THEN
          EXIT /read_file/;
        IFEND;

        NEXT the_object IN profile_file;
        IF the_object = NIL THEN
          EXIT /read_file/;
        IFEND;
        ALLOCATE profile_object_list^ [i] IN jmv$object_heap^;
        profile_object_list^ [i]^ := the_object^;
        profile_object_list^ [i]^.attributes.kind := jmc$empty;
        profile_object_list^ [i]^.references := 0;
        profile_object_list^ [i]^.changed := FALSE;
      FOREND;

      FOR i := 1 TO objects_on_profile DO
        the_object := profile_object_list^ [i];
        read_attributes (jmv$object_definition [the_object^.kind].declaration,
              the_object^.attributes, status);
        IF NOT status.normal THEN
          EXIT /read_file/;
        IFEND;
      FOREND;

      FOR object_kind := LOWERVALUE (object_kind)
            TO UPPERVALUE (object_kind) DO
        previous_object := the_profile.objects [object_kind];
        WHILE previous_object <> NIL DO
          jmp$delete_attributes (previous_object^.attributes);
          the_object := previous_object;
          previous_object := previous_object^.next_object;
          FREE the_object IN jmv$object_heap^;
        WHILEND;
        the_profile.count [object_kind] := 0;
        the_profile.objects [object_kind] := NIL;
      FOREND;
      the_profile.definition_id := header^.definition_id;

      object_kind := UPPERVALUE (object_kind);
      FOR i := 1 TO objects_on_profile DO
        the_object := profile_object_list^ [i];
        the_object^.next_object := NIL;
        IF the_object^.kind = object_kind THEN
          previous_object^.next_object := the_object;
          the_profile.count [object_kind] :=
                the_profile.count [object_kind] + 1;
        ELSE
          object_kind := the_object^.kind;
          the_profile.objects [object_kind] := the_object;
          the_profile.count [object_kind] := 1;
        IFEND;
        previous_object := the_object;
      FOREND;

      RETURN;
    END /read_file/;

    osp$set_status_condition (jme$cannot_read_profile, status);

    FOR i := 1 TO objects_on_profile DO
      the_object := profile_object_list^ [i];
      IF the_object <> NIL THEN
        jmp$delete_attributes (the_object^.attributes);
        FREE the_object IN jmv$object_heap^;
      IFEND;
    FOREND;
  PROCEND read_profile;
?? TITLE := 'write_profile', EJECT ??

{ PURPOSE:
{   This interface writes the profile to the specified file.
{
{ DESIGN:
{   The header is written first.
{   All the objects are written second.
{   The attributes for each object are written in the order of the objects.

  PROCEDURE write_profile
    (    profile_file_identifier: amt$file_identifier;
     VAR the_profile: jmt$profile_data;
     VAR status: ost$status);

    VAR
      profile_file: ^SEQ ( * );

?? NEWTITLE := 'write_attributes', EJECT ??

{ PURPOSE:
{   This routine writes attributes onto the profile file.
{
{ DESIGN:
{   The routine puts a header on the file first which contains a description
{   of the attribute type in a string.  Then a copy of the attribute is put
{   on the file.  If the attribute is of type list, range, or type then the
{   routine is called recursively for each item in the list.  Names and
{   strings are stored immediatly following the attribute.  Object references
{   are kept as an index into the object headers written in the front of the
{   file.
{
{ NOTES:
{   The string stored in the header provides a safety check when reading the
{   file back in.

    PROCEDURE write_attributes
      (VAR attribute: jmt$object_attribute;
       VAR status: ost$status);

      VAR
        i: integer,
        file: ^fst$file_reference,
        name: ^ost$name,
        attribute_on_profile: ^jmt$object_attribute,
        item: ^item_header;

      status.normal := FALSE;
      NEXT item IN profile_file;
      IF item = NIL THEN
        RETURN;
      IFEND;
      item^.name := bad_item_id;

      NEXT attribute_on_profile IN profile_file;
      IF attribute_on_profile = NIL THEN
        RETURN;
      IFEND;

      attribute_on_profile^ := attribute;

      CASE attribute.kind OF
      = jmc$list, jmc$range, jmc$type, jmc$editable_list =
        item^.size := UPPERBOUND (attribute.attribute_list^);

        FOR i := 1 TO UPPERBOUND (attribute.attribute_list^) DO
          write_attributes (attribute.attribute_list^ [i], status);
          IF NOT status.normal THEN
            RETURN;
          IFEND;
        FOREND;

      = jmc$name =
        NEXT name IN profile_file;
        IF name = NIL THEN
          RETURN;
        IFEND;
        name^ := attribute.name^;

      = jmc$file =
        item^.size := STRLENGTH (attribute.file^);
        NEXT file: [STRLENGTH (attribute.file^)] IN profile_file;
        IF file = NIL THEN
          RETURN;
        IFEND;
        file^ := attribute.file^;

      = jmc$object =
        item^.size := attribute.object_p^.profile_index;
        attribute_on_profile^.profile_object_index :=
              attribute.object_p^.profile_index;

      ELSE
        item^.size := 0;
      CASEND;

      item^.name := attribute_kind_id [attribute.kind];

      status.normal := TRUE;
    PROCEND write_attributes;
?? OLDTITLE, EJECT ??

    VAR
      local_status: ost$status,
      item: ^item_header,
      segment_pointer: amt$segment_pointer;

    VAR
      the_object: jmt$profile_object_reference,
      object_on_profile: jmt$profile_object_reference,
      object_kind: jmt$profile_object_kinds,
      header: ^jmt$profile_header,
      max_index: integer,
      i: integer,
      j: integer;

    status.normal := TRUE;

    amp$get_segment_pointer (profile_file_identifier, amc$sequence_pointer,
          segment_pointer, status);
    IF NOT status.normal THEN
      RETURN
    IFEND;
    RESET segment_pointer.sequence_pointer;
    profile_file := segment_pointer.sequence_pointer;

    NEXT header IN profile_file;
    header^.version := 'GARBAGE';

    j := 0;
    FOR object_kind := LOWERVALUE (object_kind) TO UPPERVALUE (object_kind) DO

      the_object := the_profile.objects [object_kind];
      max_index := 0;
      WHILE the_object <> NIL DO
        j := j + 1;
        the_object^.profile_index := j;
        NEXT item IN profile_file;
        item^.name := 'OBJI';
        item^.size := j;
        NEXT object_on_profile IN profile_file;
        object_on_profile^ := the_object^;
        IF the_object^.index > max_index THEN
          max_index := the_object^.index;
        IFEND;
        the_object := the_object^.next_object;
      WHILEND;

      IF object_kind = jmc$profile_job_class THEN
        header^.maximum_job_class_index := max_index;
      ELSEIF object_kind = jmc$profile_service_class THEN
        header^.maximum_service_class_index := max_index;
      ELSEIF object_kind = jmc$profile_application THEN
        header^.application_count := max_index;
      IFEND;

    FOREND;

    FOR object_kind := LOWERVALUE (object_kind) TO UPPERVALUE (object_kind) DO
      the_object := the_profile.objects [object_kind];
      WHILE the_object <> NIL DO
        write_attributes (the_object^.attributes, status);
        IF NOT status.normal THEN
          RETURN;
        IFEND;
        the_object := the_object^.next_object;
      WHILEND;
    FOREND;

    header^.definition_id := the_profile.definition_id;
    header^.object_count := j;
    header^.version := jmc$profile_version;

    segment_pointer.sequence_pointer := profile_file;
    amp$set_segment_eoi (profile_file_identifier, segment_pointer, status);
    IF NOT status.normal THEN
      RETURN;
    IFEND;

  PROCEND write_profile;
MODEND jmm$administer_profile;
