home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / PIBT41S4.ZIP / SETPARAM.MOD < prev    next >
Encoding:
Text File  |  1988-02-06  |  15.3 KB  |  448 lines
  1. (*--------------------------------------------------------------------------*)
  2. (*           Look_Up_Parameter --- See if parameter name found              *)
  3. (*--------------------------------------------------------------------------*)
  4.  
  5. FUNCTION Look_Up_Parameter( PName : Char_2 ) : INTEGER;
  6.  
  7. (*--------------------------------------------------------------------------*)
  8. (*                                                                          *)
  9. (*     Function:  Look_Up_Parameter                                         *)
  10. (*                                                                          *)
  11. (*     Purpose:   Looks up parameter name in parameter name list            *)
  12. (*                                                                          *)
  13. (*     Calling Sequence:                                                    *)
  14. (*                                                                          *)
  15. (*        Param_Num := Look_Up_Parameter( PName: Char_2 ) : INTEGER;        *)
  16. (*                                                                          *)
  17. (*           PName      --- parameter name to look up                       *)
  18. (*           Param_Num  --- parameter number of this line                   *)
  19. (*                                                                          *)
  20. (*     Calls:  None                                                         *)
  21. (*                                                                          *)
  22. (*--------------------------------------------------------------------------*)
  23.  
  24. VAR
  25.    Hi        : INTEGER;
  26.    Lo        : INTEGER;
  27.    Mid       : INTEGER;
  28.    Param_Num : INTEGER;
  29.  
  30. BEGIN (* Look_Up_Parameter *)
  31.  
  32.    Hi        := Max_Param_Names;
  33.    Lo        := 1;
  34.    Param_Num := 0;
  35.  
  36.    REPEAT
  37.  
  38.       Mid := ( Lo + Hi ) DIV 2;
  39.  
  40.       IF ( PName = Parameters[Mid].PName ) THEN
  41.          BEGIN
  42.             Param_Num := Mid;
  43.             Lo        := SUCC( Hi );
  44.          END
  45.  
  46.       ELSE IF ( PName < Parameters[Mid].PName ) THEN
  47.          Hi := PRED( Mid )
  48.       ELSE
  49.          Lo := SUCC( Mid );
  50.  
  51.    UNTIL( Lo > Hi );
  52.  
  53.    Look_Up_Parameter := Param_Num;
  54.  
  55. END   (* Look_Up_Parameter *);
  56.  
  57. (*----------------------------------------------------------------------*)
  58. (*         Set_Parameter --- Set value of PibTerm parameter             *)
  59. (*----------------------------------------------------------------------*)
  60.  
  61. PROCEDURE Set_Parameter( Param_Num  : INTEGER;
  62.                          Param_Ival : INTEGER;
  63.                          Param_Rval : LONGINT;
  64.                          Param_Str  : AnyStr   );
  65.  
  66. (*----------------------------------------------------------------------*)
  67. (*                                                                      *)
  68. (*     Procedure:  Set Parameter                                        *)
  69. (*                                                                      *)
  70. (*     Purpose:    Set value of PibTerm parameter                       *)
  71. (*                                                                      *)
  72. (*     Calling Sequence:                                                *)
  73. (*                                                                      *)
  74. (*        Set_Parameter( Param_Num  : INTEGER;                          *)
  75. (*                       Param_Ival : INTEGER;                          *)
  76. (*                       Param_Rval : LONGINT;                          *)
  77. (*                       Param_Str  : AnyStr   );                       *)
  78. (*                                                                      *)
  79. (*           Param_Num  --- Parameter to set                            *)
  80. (*           Param_Ival --- integer parameter value                     *)
  81. (*           Param_Rval --- real parameter value                        *)
  82. (*           Param_Str  --- string parameter value                      *)
  83. (*                                                                      *)
  84. (*----------------------------------------------------------------------*)
  85.  
  86. VAR
  87.    I      : INTEGER;
  88.    IWord  : WORD;
  89.    Ch2    : STRING[2];
  90.    P_Ptr  : POINTER;
  91.    P_IPtr : Param_IPtr_Type ABSOLUTE P_Ptr;
  92.    P_XPtr : Param_XPtr_Type ABSOLUTE P_Ptr;
  93.    P_SPtr : Param_SPtr_Type ABSOLUTE P_Ptr;
  94.    P_CPtr : Param_CPtr_Type ABSOLUTE P_Ptr;
  95.    P_LPtr : Param_LPtr_Type ABSOLUTE P_Ptr;
  96.    P_BPtr : Param_BPtr_Type ABSOLUTE P_Ptr;
  97.    P_TPtr : Param_TPtr_Type ABSOLUTE P_Ptr;
  98.    P_FPtr : Param_FPtr_Type ABSOLUTE P_Ptr;
  99.    P_DPtr : Param_DPtr_Type ABSOLUTE P_Ptr;
  100.    P_OPtr : Param_OPtr_Type ABSOLUTE P_Ptr;
  101.    P_WPtr : Param_WPtr_Type ABSOLUTE P_Ptr;
  102.  
  103. (*----------------------------------------------------------------------*)
  104. (*         Copy_First_Char --- Set value to first char of string        *)
  105. (*----------------------------------------------------------------------*)
  106.  
  107. FUNCTION Copy_First_Char : CHAR;
  108.  
  109. VAR
  110.    T: AnyStr;
  111.  
  112. BEGIN (* Copy_First_Char *)
  113.  
  114.    T := Read_Ctrls( Param_Str );
  115.  
  116.    IF ( LENGTH( T ) > 0 ) THEN
  117.       Copy_First_Char := T[1]
  118.    ELSE
  119.       Copy_First_Char := ' ';
  120.  
  121. END   (* Copy_First_Char *);
  122.  
  123. (*----------------------------------------------------------------------*)
  124. (*              Set_To_Color  --- Set value to legitimate color         *)
  125. (*----------------------------------------------------------------------*)
  126.  
  127. FUNCTION Set_To_Color : INTEGER;
  128.  
  129. BEGIN (* Set_To_Color *)
  130.  
  131.    Set_To_Color := MAX( MIN( Param_Ival , 15 ) , 0 );
  132.  
  133. END   (* Set_To_Color *);
  134.  
  135. (*----------------------------------------------------------------------*)
  136. (*              Set_Path --- Set value to fixed-up pathname             *)
  137. (*----------------------------------------------------------------------*)
  138.  
  139. FUNCTION Set_Path : AnyStr;
  140.  
  141. BEGIN (* Set_Path *)
  142.  
  143.    IF ( LENGTH( Param_Str ) > 0 ) THEN
  144.       IF ( Param_Str[ LENGTH( Param_Str ) ] <> '\' ) THEN
  145.          Param_Str := Param_Str + '\';
  146.  
  147.    Set_Path := Param_Str;
  148.  
  149. END   (* Set_Path *);
  150.  
  151. (*----------------------------------------------------------------------*)
  152. (*              Get_Hex --- Get hexadecimal value from string           *)
  153. (*----------------------------------------------------------------------*)
  154.  
  155. PROCEDURE Get_Hex( VAR Integr : WORD );
  156.  
  157. VAR
  158.    I: INTEGER;
  159.  
  160. BEGIN (* Get_Hex *)
  161.  
  162.    I := Hex_To_Dec( Param_Str , -1 );
  163.  
  164.    IF ( I <> -1 ) THEN
  165.       Integr := I;
  166.  
  167. END   (* Get_Hex *);
  168.  
  169. (*----------------------------------------------------------------------*)
  170. (*    Parse_Protocol_Definition --- Parse protocol definition           *)
  171. (*----------------------------------------------------------------------*)
  172.  
  173. PROCEDURE Parse_Protocol_Definition;
  174.  
  175. VAR
  176.    PName  : String12;
  177.    PAbbr  : String12;
  178.    Batch  : String12;
  179.    HostOK : String12;
  180.    RName  : String12;
  181.    SName  : String12;
  182.    I      : INTEGER;
  183.    L      : INTEGER;
  184.    T      : Transfer_Type;
  185.    IProt  : INTEGER;
  186.    Ch     : CHAR;
  187.  
  188. (*----------------------------------------------------------------------*)
  189.  
  190. PROCEDURE SkipBl;
  191.  
  192. BEGIN (* SkipBl *)
  193.  
  194.    WHILE( ( I < L ) AND ( Param_Str[I] = ' ' ) ) DO
  195.       INC( I );
  196.  
  197. END   (* SkipBl *);
  198.  
  199. (*----------------------------------------------------------------------*)
  200.  
  201. PROCEDURE SkipToBl;
  202.  
  203. BEGIN (* SkipToBl *)
  204.  
  205.    WHILE( ( I < L ) AND ( Param_Str[I] <> ' ' ) ) DO
  206.       INC( I );
  207.  
  208. END   (* SkipToBl *);
  209.  
  210. (*----------------------------------------------------------------------*)
  211.  
  212. PROCEDURE CopyStr( VAR S : String12; MaxLen : INTEGER );
  213.  
  214. VAR
  215.    K: INTEGER;
  216.  
  217. BEGIN (* CopyStr *)
  218.  
  219.    SkipBl;
  220.  
  221.    K := 0;
  222.  
  223.    WHILE( ( K <= MaxLen ) AND ( Param_Str[I] <> ' ' ) ) DO
  224.       BEGIN
  225.          S := S + Param_Str[I];
  226.          INC( I );
  227.          INC( K );
  228.       END;
  229.  
  230.    SkipToBl;
  231.  
  232. END   (* CopyStr *);
  233.  
  234. (*----------------------------------------------------------------------*)
  235.  
  236. BEGIN (* Parse_Protocol_Definition *)
  237.  
  238.                                    (* Set defaults *)
  239.  
  240.    Param_Str := LTrim( Param_Str );
  241.    P_SPtr^   := Param_Str;
  242.  
  243.    PName     := '';
  244.    PAbbr     := '  ';
  245.    Batch     := '';
  246.    RName     := '';
  247.    SName     := '';
  248.    HostOK    := '';
  249.                                    (* Quit if null definition *)
  250.  
  251.    IF ( LENGTH( Param_Str ) = 0 ) THEN EXIT;
  252.  
  253.    Param_Str := Param_Str + '  ';
  254.                                    (* Get abbreviation *)
  255.  
  256.    PAbbr[1]  := UpCase( Param_Str[1] );
  257.    PAbbr[2]  := UpCase( Param_Str[2] );
  258.  
  259.    I         := 3;
  260.    L         := LENGTH( Param_Str );
  261.  
  262.                                    (* Get long name    *)
  263.    CopyStr( PName , 12 );
  264.                                    (* Get batch type   *)
  265.    CopyStr( Batch , 1  );
  266.  
  267.    IF ( Batch <> '' ) THEN
  268.       Batch[1] := UpCase( Batch[1] )
  269.    ELSE
  270.       Batch[1] := ' ';
  271.                                    (* Get host/terminal mode *)
  272.    CopyStr( HostOK , 1  );
  273.  
  274.    IF ( HostOK <> '' ) THEN
  275.       HostOK[1] := UpCase( HostOK[1] )
  276.    ELSE
  277.       HostOK[1] := 'T';
  278.                                    (* Get receive script name *)
  279.    CopyStr( RName , 12 );
  280.  
  281.    IF ( RName = '*' ) THEN
  282.       RName := '';
  283.                                    (* Get send script name *)
  284.    CopyStr( SName , 12 );
  285.  
  286.    IF ( SName = '*' ) THEN
  287.       SName := '';
  288.                                    (* Find slot *)
  289.  
  290.    IProt := Param_Num - Look_Up_Parameter( 'F0' ) + ORD( PUser1 );
  291.  
  292.                                    (* Found slot -- insert protocol    *)
  293.                                    (* information.                     *)
  294.    T := Transfers[SUCC(IProt)];
  295.  
  296.    CopyS2AR( PName, Transfer_Name_List[SUCC(IProt)][1], 12 );
  297.  
  298.    Transfer_Name_List[SUCC(IProt)][0] := CHR( 12 );
  299.  
  300.    Trans_Type_Name[T][1]     := PAbbr[1];
  301.    Trans_Type_Name[T][2]     := PAbbr[2];
  302.    Single_File_Protocol[T]   := ( Batch[1]  = 'S' );
  303.    Trans_OK_In_Host[T]       := ( HostOK[1] = 'H' );
  304.    Receive_Script_Names[T]   := RName;
  305.    Send_Script_Names[T]      := SName;
  306.  
  307. END   (* Parse_Protocol_Definition *);
  308.  
  309. (*----------------------------------------------------------------------*)
  310.  
  311. BEGIN (* Set_Parameter *)
  312.                                    (* If not legal parameter number, quit *)
  313.  
  314.    IF ( ( Param_Num < 1 ) OR ( Param_Num > Max_Param_Names ) ) THEN EXIT;
  315.  
  316.                                    (* Get parameter address *)
  317.  
  318.    P_Ptr := Parameters[Param_Num].PAddr;
  319.  
  320.                                    (* Convert parameter value to string *)
  321.  
  322.    CASE Parameters[Param_Num].PType OF
  323.  
  324.       PosInt_Param  : IF ( Param_Rval <= 0 ) THEN
  325.                          P_IPtr^ := 0
  326.                       ELSE IF ( Param_Rval >= 32767 ) THEN
  327.                          P_IPtr^ := 32767
  328.                       ELSE
  329.                          P_IPtr^ := Param_Rval;
  330.  
  331.       BColor_Param,
  332.       Color_Param   : P_IPtr^ := Set_To_Color;
  333.  
  334.       String_Param  : P_SPtr^ := Read_Ctrls( Param_Str );
  335.  
  336.       Path_Param    : P_SPtr^ := Set_Path;
  337.  
  338.       Box_Param     : IF LENGTH( Param_Str ) > 0 THEN
  339.                          BEGIN
  340.                             Box_Chars := Param_Str + DUPL(' ' , 8 - LENGTH( Param_Str ) );
  341.                             WITH Menu_Box_Chars DO
  342.                                BEGIN
  343.                                   Top_Left_Corner     := Box_Chars[1];
  344.                                   Top_Line            := Box_Chars[2];
  345.                                   Top_Right_Corner    := Box_Chars[3];
  346.                                   Right_Line          := Box_Chars[4];
  347.                                   Bottom_Right_Corner := Box_Chars[5];
  348.                                   Bottom_Line         := Box_Chars[6];
  349.                                   Bottom_Left_Corner  := Box_Chars[7];
  350.                                   Left_Line           := Box_Chars[8];
  351.                               END;
  352.                          END;
  353.  
  354.       VidMode_Param : CASE Param_Str[1] OF
  355.                          'C': New_Text_Mode   := C80;
  356.                          'M': New_Text_Mode   := Mono;
  357.                          ELSE New_Text_Mode   := BW80;
  358.                       END;
  359.  
  360.       KCheck_Param,
  361.       Char_Param    : IF ( LENGTH( Param_Str ) > 0 ) THEN
  362.                          P_CPtr^ := Param_Str[1]
  363.                       ELSE
  364.                          P_CPtr^ := ' ';
  365.  
  366.       SpecChar_Param: P_CPtr^ := Copy_First_Char;
  367.  
  368.       LongInt_Param : P_XPtr^ := Param_RVal;
  369.  
  370.       Boolean_Param : P_LPtr^ := ( Param_IVal = 1 );
  371.  
  372.       Byte_Param    : P_BPtr^ := Param_IVal;
  373.  
  374.       Transfer_Param: BEGIN
  375.                          CH2 := UpCase( Param_Str[1] ) +
  376.                                 UpCase( Param_Str[2] );
  377.                          IF ( CH2 = '  ' ) THEN
  378.                             Default_Transfer_Type := Xmodem_CRC
  379.                          ELSE
  380.                             BEGIN
  381.                                FOR I := 1 TO Max_Transfer_Types DO
  382.                                   IF ( CH2 = Trans_Type_Name[Transfers[I]] ) THEN
  383.                                      Default_Transfer_Type := Transfers[I];
  384.                                IF ( CH2 = 'YM' ) THEN
  385.                                   Default_Transfer_Type := Xmodem_1K;
  386.                             END;
  387.                       END;
  388.  
  389.       Terminal_Param: IF ( ( Param_Ival >= 0 ) AND ( Param_Ival <= NumberTerminalTypes ) ) THEN
  390.                          Terminal_To_Emulate := Terminal_Type_List[ Param_Ival ]
  391.                       ELSE
  392.                          Terminal_To_Emulate := DUMB;
  393.  
  394.       Date_Param    : BEGIN
  395.                          Param_Str := UpperCase( Param_Str );
  396.                          IF ( Param_Str = 'YMD' ) THEN
  397.                             Date_Format := YMD_Style
  398.                          ELSE IF ( Param_Str = 'MDY' ) THEN
  399.                             Date_Format := MDY_Style
  400.                          ELSE IF ( Param_Str = 'DMY' ) THEN
  401.                             Date_Format := DMY_Style;
  402.                       END;
  403.  
  404.       Time_Param   :  BEGIN
  405.                          Param_Str := UpperCase( Param_Str );
  406.                          IF Param_Str = 'AMPM' THEN
  407.                             Time_Format := AMPM_Time
  408.                          ELSE IF Param_Str = 'MILITARY' THEN
  409.                             Time_Format := Military_Time;
  410.                          Use_Military := ( Time_Format = Military_Time );
  411.                       END;
  412.  
  413.       ScrOrder_Param: CASE Param_Ival OF
  414.                          0: Script_Search_Order := Dir_Then_Lib;
  415.                          1: Script_Search_Order := Lib_Then_Dir;
  416.                          2: Script_Search_Order := Dir_Only;
  417.                          3: Script_Search_Order := Lib_Only;
  418.                          ELSE
  419.                             Script_Search_Order := Dir_Then_Lib;
  420.                       END (* CASE *);
  421.  
  422.       Hexi_Param    : BEGIN
  423.                          Get_Hex( IWord );
  424.                          P_WPtr^ := IWord;
  425.                       END;
  426.  
  427.       Word_Param    : P_WPtr^ := Param_RVal;
  428.  
  429.       ExtTrans_Param: Parse_Protocol_Definition;
  430.  
  431.       Integer_Param : IF ( Param_Rval < -32768 ) THEN
  432.                          P_IPtr^ := -32768
  433.                       ELSE IF ( Param_Rval >= 32767 ) THEN
  434.                          P_IPtr^ := 32767
  435.                       ELSE
  436.                          P_IPtr^ := Param_Rval;
  437.  
  438.       ELSE          ;
  439.  
  440.    END (* CASE *);
  441.  
  442.    IF Silent_Mode THEN Play_Music_On := FALSE;
  443.    Menu_Set_Beep( NOT Silent_Mode );
  444.  
  445.    Reset_Comm_Port := TRUE;
  446.  
  447. END   (* Set_Parameter *);
  448.