Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/PASNET.ZIP/SAMPLE1.PAS

Pascal/Delphi Source File | 1988-06-28 | 40.2 KB | 1,155 lines

{ This program has been designed to give developers an  example of how to interface
with the assembly library provided.  The library has been revised and the
version contained on this disk should be used in place of the original library
that came with the programmers' guide diskette. The programmers' guide will
help provide a better understanding of what parameters each call needs and
how each function works.  The following declaration needs to made when ever the
library routines are accessed, since all function calls are referenced from
the "xtndopn" function.
                         ALWAYS DECLARE THE FOLLOWING:
function xtndopn(var mode,handle:integer;var filename:str):integer; external 'pasneta'; }

{===========================================================================================}

program FuncInterface;

uses
   Dos,
   Crt,
   PasNet;

    type   str = string[52];

    var
         hex,filename,asciiz,sema4,recstr,request,reply: str;
         Handle, retcode, Hoff, Loff, HLen, LLen, FLAG, TMO, Func, Attribute: integer;
         semavalu,Hihandle,Lohandle,opencnt,volume,newserv: integer;
         I, Len, mode, seg, off: integer;
         ans: char;


procedure Explain;

    begin
        writeln('This program will display a menu of different function calls that can be');
        writeln('performed. Each call will prompt the user for the parameters needed by the');
        writeln('function call.  After a function call has completed execution, the user ');
        writeln('must hit the <enter>  key to get back to the main menu.  This program has ');
        writeln('been written to provide examples of how to use the function call interfaces,');
        writeln('contained in pasneta.asm.');
    write('       Type return to continue: ');
        readln;
        clrscr;
    end;


function HexConvert(num:integer):str;
    var quot, rem: integer;
        dum:str;

    begin
        quot:=num div 16;
        rem:= num mod 16;

        case rem of
            0:hex:='0'+hex;
            1:hex:='1'+hex;
            2:hex:='2'+hex;
            3:hex:='3'+hex;
            4:hex:='4'+hex;
            5:hex:='5'+hex;
            6:hex:='6'+hex;
            7:hex:='7'+hex;
            8:hex:='8'+hex;
            9:hex:='9'+hex;
            10:hex:='A'+hex;
            11:hex:='B'+hex;
            12:hex:='C'+hex;
            13:hex:='D'+hex;
            14:hex:='E'+hex;
            15:hex:='F'+hex;
        end;

        if quot > 15 then
            dum:=HexConvert(quot)
        else
            begin
                case quot of
                    0:hex:='0'+hex;
                    1:hex:='1'+hex;
                    2:hex:='2'+hex;
                    3:hex:='3'+hex;
                    4:hex:='4'+hex;
                    5:hex:='5'+hex;
                    6:hex:='6'+hex;
                    7:hex:='7'+hex;
                    8:hex:='8'+hex;
                    9:hex:='9'+hex;
                    10:hex:='A'+hex;
                    11:hex:='B'+hex;
                    12:hex:='C'+hex;
                    13:hex:='D'+hex;
                    14:hex:='E'+hex;
                    15:hex:='F'+hex;
                end;
            end;
        hexconvert:=hex;
    end;


procedure get_filename;

    begin
        write('Enter the name of the file you want to use:  ');
        readln(filename);
        write('Press the <enter> key to begin .....');
        readln;
        Len:=length(filename);
        filename[Len+1]:=chr(0);        { Make it an ASCIIZ string }
    end;


(************************************************************************)
(* Open_File is the Novell Extended Open Function Call. It opens the    *)
(* file shareable, read/write.                                          *)
(************************************************************************)
procedure open;

    begin
        get_filename;
        writeln('The file is being opened Sharable Read Write');
        writeln('This is accomplished by placing a hex 42 in the AL register');
        write('Type return to continue......');
    readln;
    flag:=$42;
        clrscr;
        retcode:=xtndopn(flag,handle,filename);
        if retcode <> 0 then
            writeln('Return code = ',hexconvert(retcode),' file has not been opened')
        else
            begin
                writeln('The file handle is ',handle,' the return code is : ',retcode);
                writeln('Remember the file handle number above, it will be needed to release locked records.');
            end;
    end;


(*************************************************************************)
(* Get or Set file Attributes *)
(*************************************************************************)

procedure setget;
    var get:integer;

    begin
        get:=0;
        get_filename;
        writeln('Enter a ''0'' to get the attributes.');
        write('Enter a ''1'' to set the attributes: ');
        readln(func);
        if func = 1 then
            begin
                writeln('Enter one of the following attributes: ');
                writeln;
                writeln('1 - Read only. 2 - Hidden. 4 - system. 128 - Sharable.');
                readln(attribute);
            end
        else
            get:=1;
        retcode:=setattr(FUNC,ATTRIBUTE,filename);
        if get = 1 then
            writeln(' The attribute is : ',hexconvert(attribute));
         writeln('The return code is: ',retcode);
    end;

(************************************************************************)
(* Set EOJ flag *)
(************************************************************************)

procedure SetEOJ;

    begin
        writeln('Enter a ''0'' to disable the End Of Job flag.');
    write('Enter a ''1'' to enable the End Of Job flag: ');
        readln(flag);
        retcode:=eojstat(flag);
        writeln('The return code is: ',retcode);
    end;


(************************************************************************)
(* Physical record LOG and LOCK  *)
(************************************************************************)

procedure Log_Lock;

    begin
        ans:='n';
        write('If the target file is already open, type a ''y'': ');
        readln(ans);
        if ans <> 'y' then
            OPEN
        else
            begin
                write('Enter the appropriate file handle: ');
                readln(handle);
            end;
        write('Enter the Low Word Starting Offset of the record: ');
        readln(Loff);
        write('Enter the High Word Starting Offset of the record: ');
        readln(Hoff);
        write('Enter the Low Word Length of the record: ');
        readln(LLen);
        write('Enter the High Word Length of the record: ');
        readln(HLen);
        write('Enter a ''1'' to lock and log, or enter a ''3'' to do a shared lock: ');
    readln(flag);
       if flag = 1 then
            begin
                 write('Enter the lock timeout in 1/18 secs intervals: ');
                readln(TMO);
            end;
        retcode:=PRLH_Log(handle,Hoff,Loff,HLen,LLen,Flag,TMO);
        writeln('The return code is: ',retcode);
    end;


(**************************************************************************)
(* PRLH_Rel  -  Release a record, but it keep it in the log table. *)
(* PRLH_CLr  -  Release a record and remove it from the log table (clear the record).*)
(**************************************************************************)

procedure Rel_Clr;

    begin
        ans:='n';
        writeln('To release a record you must have opened the file and obtained a valid file handle.');
    write('To proceed type a ''y'': ');
    readln(ans);
        if ans = 'y' then
            begin
                write('Enter the file handle of the appropriate file: ');
                readln(handle);
                write('Enter the Low Word Starting Offset of the record: ');
        readln(Loff);
            write('Enter the High Word Starting Offset of the record: ');
        readln(Hoff);
            write('Enter the Low Word Length of the record: ');
        readln(LLen);
            write('Enter the High Word Length of the record: ');
        readln(HLen);
            write('If you want to release the record, but not remove it from the log table, type an ''r'': ');
            readln(ans);
            if ans ='r' then
                 begin
                      writeln('Releasing the record...');
                  retcode:=PRLH_Rel(handle,Hoff,Loff,HLen,LLen);
                 end
                else
                 begin
                      writeln('Removing the record from the log table...');
                   retcode:=PRLH_Clr(handle,Hoff,Loff,HLen,LLen);
                 end;
            writeln('The return code is: ',retcode);
            end;
        end;


(*********************************************************************)
(* PRLS_Lck  -  Lock the record set (all records in the log table *)
(* PRLS_Rel  -  Release record set  *)
(* PRLS_Clr     Release, and clear the record set from the log table.*)
(*********************************************************************)

procedure Lock_Set;

    begin
        write('Enter a ''1'' to do a shared lock, nonexclusive:  ');
        readln(flag);
        write('Enter the timeout amount in 1/18 secs intervals, 0 means no wait: ');
    readln(TMO);
      retcode:=PRLS_Lck(flag,TMO);
      writeln('The return code is: ',retcode);
    end;


 procedure Set_Rel_Clr;

    begin
        ans:='n';
      writeln('To release the entire record set without removing the records');
        write('from the log table, enter an ''r'' : ');
    readln(ans);
        if ans = 'r' then
            begin
                writeln('Releasing the record set...');
                 retcode:=PRLS_Rel;
            end
       else
            begin
                write('Removing all records from log table...');
                retcode:=PRLS_Clr;
            end;
        write('Return code is : ',retcode);
    end;


(**********************************************************************)
(* Open a Semaphore *)
(**********************************************************************)

procedure Sem_Open;

    begin
        write('Enter the name of the semaphore: ');
    readln(sema4);
        write('Enter the initial semaphore value, it must be positive: ');
    readln(semavalu);
        retcode:=opensem(sema4,semavalu,Hihandle,Lohandle,opencnt);
        writeln;writeln;
        writeln('The return code is : ',retcode);
    writeln('The number of stations using this semaphore is : ',opencnt);
        write('The semaphore handle is : HiPart = ',hexconvert(Hihandle));
        hex:=' ';
        writeln(' LoPart = ',hexconvert(Lohandle));
        writeln('WRITE DOWN THIS HANDLE EXACTLY AS YOU SEE IT, IT WILL BE NEEDED TO ACCESS THIS SEMAPHORE');
        writeln;
    end;


procedure Sem_Exam;

    begin
        writeln('When entering the file handle, enter the HEX digits in the following manner: ');
        writeln('    ie.    low part first: $adcb  (put a ''$'' before the hex digits) ');
        writeln;
        write('Enter the semaphore handle, low part first: ');
    readln(Lohandle);
        write('  enter the high part of the handle: ');
    readln(Hihandle);
        retcode:=ExamSem(Hihandle,Lohandle,semavalu,opencnt);
        writeln('The return code is : ',retcode);
        writeln('The open count is : ',opencnt);
        writeln('The semaphore value is : ',semavalu);
    end;


procedure Sem_Wait_Sig;

    begin
        ans:='n';
        writeln('When entering the file handle, enter the HEX digits in the following manner: ');
        writeln('    ie.    low part first: $adcb  (put a ''$'' before the hex digits) ');
        writeln;
        write('Enter the semaphore handle, low part first: ');
    readln(Lohandle);
        write('  enter the high part of the handle: ');
    readln(Hihandle);
        writeln('     If you desire to SIGNAL the semaphore (increment) ');
        write('  enter an ''s'' else type return: ');
        readln(ans);
        if ans = 's' then
            retcode:= SigSem(Hihandle,Lohandle)
         else
            begin
                write('Enter the timeout value in 1/18 secs intervals: ');
        readln(TMO);
        writeln;
                write('waiting... ');
              retcode:=WaitSem(Hihandle,Lohandle,TMO);
            end;
        writeln('The return code is : ',retcode);
    end;


procedure Sem_Close;

    begin
        writeln('When entering the file handle, enter the HEX digits in the following manner: ');
        writeln('    ie.    low part first: $adcb  (put a ''$'' before the hex digits) ');
        writeln;
        write('Enter the semaphore handle, low part first: ');
    readln(Lohandle);
        write('  enter the high part of the handle: ');
    readln(Hihandle);
        retcode:= ClosSem(Hihandle,Lohandle);
        writeln('    closing... the return code is : ',retcode);
    end;


(************************************************************************)
(* GetOrSet_LockMode sets the Lock Mode to 01 as explained in Function      *)
(* call guide.                                                          *)
(************************************************************************)

procedure GetOrSet_LockMode;

    begin
       writeln('Enter one of the following choices: ');
    writeln;
       writeln('      0 - set to old compatibility mode');
       writeln('      1 - set to new extended locks mode');
       write('      2 - return current lock mode    ---->  ');
    readln(func);
       retcode:=setlck(func);
       writeln('Current lock mode is : ',retcode);
    end;


(************************************************************************)
(* Transaction Tracking Begin, End, TTS verify, Abort trans,
   Transaction status *)
(************************************************************************)


procedure TTS_functions;

    begin
     writeln('Enter a TTS function code');
        writeln('  Enter a ''0'' to begin a transaction');
        writeln('  Enter a ''1'' to end a transaction (Note - NO Transaction Reference No. is returned)');
        writeln('  Enter a ''2'' to verify whether or not the preferred file server supports transaction tracking');
        writeln('  Enter a ''3'' to abort a transaction');
       write('  ------> ');
    readln(func);
      retcode:=BakOuts(func);
      writeln('The return code is : ',retcode);
    end;


(*************************************************************************)
(* Begin or End logical locking read-modify-update cycle *)
(*************************************************************************)

procedure Logical_Begin_End;

    begin
      writeln('To begin logical locking enter a ''b''');
        writeln('To end logical locking enter an ''e''');
        write('-------> ');
    readln(ans);
      if ans = 'b' then
           begin
                ans:='n';
            write('This function assumes that the Lock Mode has been set to 1. If true, type a ''y'' : ');
            readln(ans);
                if ans = 'y' then
                 begin
                        write('Enter the time out amount in 1/18 secs intervels : ');
            readln(TMO);
                  retcode:=btrans(TMO);
                        write('Logical locking installed');
                 end;
           end
    else
           begin
                retcode:=etrans;
        write('Logical locking ended');
           end;
      writeln('The return code is : ',retcode);
    end;


(**************************************************************************)
(* Logical record lock functions--Log, Lock, Unlock, Unlock set, Clear rec,
   Clear set *)
(**************************************************************************)

procedure Logical_locking;

    begin
      ans:='n';
      write('This procedure assumes the Lock Mode has been set to 1 if true enter a ''y'': ');
    readln(ans);
      if ans = 'y' then
           begin
            writeln('Choose one of the following functions: ');
            writeln('    0 - Log and Lock a logical record');
            writeln('    1 - Lock all the logical records in the log table');
            writeln('    2 - Release a logical record lock, but do not remove it from the log table');
            writeln('    3 - Release all the logical records in the log table');
            writeln('    4 - Release and remove a logical record it from the log table');
            writeln('    5 - Release and remove the entire logical record set from the log table');
            write(' ----> ');readln(ans);
            if ans ='0' then
                 begin
                  clrscr;
                  writeln('You have chosen to Log and Lock a record ');
            writeln;
                  writeln('Enter a ''1'' to Log and Lock the record (exclusive lock)');
            writeln('Enter a ''3'' to Log and Lock the record  (non-exclusive lock)');
            write('------>');
            readln(flag);
                  write('Enter the record string to lock : ');
            readln(recstr);
                  write('Enter the time out amount in 1/18 sec intervals : ');
            readln(TMO);
                  retcode:=reclog(recstr,flag,TMO);
                 end
            else if ans = '1' then
                 begin
                  clrscr;
                  writeln('You have chosen to Lock the Record Set ');
                  write('Enter the time out in 1/18 sec intervels : ');
            readln(TMO);
                  retcode:=reclck(TMO);
                 end
            else if ans = '2' then
                 begin
                  clrscr;
                  writeln('You have chosen to release a record');
                  write('Enter the name of the record string : ');
            readln(recstr);
                  retcode:=reculk(recstr);
                 end
            else if ans = '3' then
                 begin
                  retcode:=reculks;
                  write('Record set released');
                 end
            else if ans = '4' then
                 begin
                  clrscr;
                  writeln('You have chosen to clear a record');
                  write('Enter the name of the record string : ');
            readln(recstr);
                  retcode:=recclr(recstr);
                 end
            else if ans = '5' then
                 begin
                  retcode:=recclrs;
                  write('Record Set Cleared');
                 end;
             writeln('The return code is : ',retcode);
           end;
    end;


(**********************************************************************)
(* Execute an End Of Job call *)
(**********************************************************************)

procedure EndOfJob;

    begin
    retcode:=eoj;
    writeln('EOJ function call completed');
      writeln('The return code is : ',retcode);
     end;


(********************************************************************)
(* Logout from the network *)
(********************************************************************)

procedure Sys_logout;

    begin
    writeln('Executing the logout function call');
      retcode:=sysout;
      writeln('The return code is : ',retcode);
    end;


(*******************************************************************)
(* Get the volume statistics *)
(*******************************************************************)

procedure Get_Vol_Stat;

    begin
       write('Enter the volume number : ');
    readln(volume);
    reply:='hi there';
      retcode:=volstat(volume,reply);
      writeln('executing... The return code is : ',retcode);
      writeln;
      writeln('Number of sectors per block : ',ord(reply[1]),ord(reply[2]));
      writeln('Number of total blocks : ',ord(reply[3]),ord(reply[4]));
      writeln('Number of unused blocks : ',ord(reply[5]),ord(reply[6]));
      writeln('Number of directory entries : ',ord(reply[7]),ord(reply[8]));
      writeln('Number of unused directory entries : ',ord(reply[9]),ord(reply[10]));
      write('Volume Name : ',reply[11],reply[12],reply[13],reply[14],reply[15],reply[16]);
      write(reply[17],reply[18],reply[19],reply[20],reply[21],reply[22]);
      writeln(reply[23],reply[24],reply[25],reply[26]);
      writeln('Removeable flag - 00 if volume is not removeable : ',ord(reply[27]),ord(reply[28]));
    end;


(***********************************************************************)
(* Find number of local disk that the shell has drives mapped to *)
(***********************************************************************)

procedure Number_Loc_drv;
    begin
      retcode:=locdrv;
      writeln('Number of local drives : ',retcode);
    end;


(***********************************************************************)
(* Get the Logical station number *)
(***********************************************************************)

procedure Logical_Sta_Num;
    begin
      retcode:=wsid;
      writeln('The logical station number is : ',retcode);
    end;


(*************************************************************************)
(* SetErrorMode sets the Error Mode to 1, so that the program will       *)
(* have control.                                                         *)
(*************************************************************************)

procedure SetErrorMode;
    begin
       writeln('To set the error mode');
      writeln('Enter one of the following : ');
      writeln('      0 - to display errors on screen');
      writeln('      1 - Extended errors for all file I/O returned in AL');
      writeln('      2 - Critical errors returned in AL (Netware 2.x and up)');
      write('------>  ');
    readln(func);
      retcode:=errmode(func);
      writeln('The previous error mode was : ',retcode);
    end;


(*************************************************************************)
(* This function allows programs to change the way the shell treats network *)
(* broadcast messages. *)
(*************************************************************************)

procedure Change_Bcast;

    begin
      writeln('To set the broadcast mode, choose one of the following : ');
      writeln('       0 - Receive console and workstation broadcasts');
      writeln('       1 - Receive console broadcasts only');
      writeln('       2 - Disable receipt of all broadcasts');
      writeln('       3 - Store broadcast messages');
      writeln('       4 - Return current broadcast mode');
      writeln('       5 - Shell timer interrupt checks are disabled');
      writeln('       6 - Shell timer interrupts are enabled');
      write('---->  ');
    readln(func);
      retcode:=bcsmode(func);
      writeln;
    writeln('The current mode is : ',retcode);
    end;


(************************************************************************)
(* The Modify LST Device function enables the use of the network spool device*)
(************************************************************************)

procedure Spool_func;

    begin
      writeln('You have chosen to start your spool device, enter one of the following :');
      writeln('       0 - Start the LST catch');
      writeln('       1 - End the LST catch and queue for printing');
      writeln('       2 - End the LST catch and abort print');
      writeln('       3 - Queue for printing and restart LST catch');
      write('---->  ');
    readln(func);
      retcode:=ctlspl(func);
      writeln;
    writeln('The return code is : ',retcode);
    end;


(*********************************************************************)
(* Spool data to a capture file located on the server *)
(*********************************************************************)

procedure Spool_Capture;
    var packet, tab, copy, prnt, form: integer;
        ban: str;
        res: char;

    begin
        ans:='n';
      writeln('Choose one of the following spool functions : ');
      writeln('              0 - Spool data to a capture file on the server');
      writeln('              1 - Close and Queue or Abort the capture file');
      writeln('              2 - Set the spool flags');
      write('---->  ');
    readln(func);
    writeln;
      if func = 0 then
           begin
            writeln('Enter the string to be spooled (length = 1 to 52) :');
              readln(request);
            request:=chr(length(request) + 1) + chr(0) + chr(func) + request;
           end
      else if func = 1 then
           begin
            write('If you want to ABORT the queue type a ''y'' : ');
        readln(ans);
            if ans = 'y' then
                  request:=chr(2) + chr(0) + chr(func) + chr(255)
            else request:=chr(1) + chr(0) + chr(func);
           end
      else if func = 2 then
           begin
            write('Do you want a banner page? (y/n) : ');
        readln(ans);
            if ans = 'y' then
            packet:=21
        else packet:=6;
         writeln('Enter the print flags, the choices are: ');
            writeln('    08h - Suppress auto form feed at the end of a print job');
            writeln('    20h - Delete spool file after printing');
            writeln('    40h - Enable tab expansion');
            writeln('    80h - Print a banner page');
            writeln('  example: to suppress form feed and print a banner page add the two numbers');
            writeln('    in HEX --> 008h + 80h = 88h.   TO ENTER --> $88 ($ = HEX) ');
        writeln;
            write('--->  ');
        readln(flag);
        writeln;
            write('Enter the Tab size 1..20 : ');
        readln(tab);
            write('Enter the target printer 0..p : ');
        readln(prnt);
            write('Enter the number of copies to print 0..255 (0 copies = no printing : ');
        readln(copy);
            write('Enter the form type 0..255 : ');
        readln(form);
            write('Enter the string for the banner 1..13 chars : ');
        readln(ban);
            request:=chr(packet)+chr(0)+chr(2)+chr(flag)+chr(tab)+chr(prnt)+chr(copy)+chr(form)+res+ban+chr(0);
        end;
    reply:=chr(0) + chr(0);
      retcode:=splreq(request,reply);
      writeln('The return code is : ',retcode);
    end;

(*************************************************************************)
(* Network Communication Function Calls-- Pipes and broadcast *)
(*************************************************************************)

procedure Pipes;
    var numsta,stanum: integer;
        message: str;

    begin
        writeln('Choose one of the following piping functions: ');
      writeln;
      writeln('       0 - Send a broadcast message');
      writeln('       1 - Get a broadcast message');
      writeln('       2 - Disable station broadcasts');
      writeln('       3 - Enable station broadcasts');
      writeln('   Pipe functions can be added, see function call manual');
      writeln;
      write('-----> ');
    readln(func);
    writeln;
      reply:=chr(255)+chr(0);
      if func = 0 then
           begin
            writeln('For our purposes, only one station needs to receive the message ');
            write('Enter the station number: ');
        readln(stanum);
        numsta:=1;
            write('Enter the string you want to send: ');
        readln(message);
            request:= chr(length(message)+4)+chr(0)+chr(0)+chr(numsta)+chr(stanum)+chr(length(message))+message;
            retcode:=pipreq(request,reply);
           end
      else if func = 1 then
           begin
            request:=chr(1)+chr(0)+chr(1);
            retcode:=pipreq(request,reply);
            reply[0]:=chr(ord(reply[3])+3);    { make printable to the screen }
            reply[3]:=chr(0);                  { "       "   "       "     "   "    }
            writeln(reply);
           end
      else if func = 2 then
           begin
            request:=chr(1)+chr(0)+chr(2);
            retcode:=pipreq(request,reply);
           end
      else if func = 3 then
           begin
            request:=chr(1)+chr(0)+chr(3);
            retcode:=pipreq(request,reply);
           end;
      writeln;
      writeln('Error code is: ',retcode);
    end;


(************************************************************************)
(* Directory Request functions *)
(************************************************************************)

procedure directory;
    var sbase: integer;

    begin
      writeln('Get the Base Path Mapping for the entered drive');
      write('Enter a SOURCEBASE (drive handle--1 or 2): ');
    readln(sbase);
      request:=chr(2)+chr(0)+chr(1)+chr(sbase);
      reply:=chr(255)+chr(0);
      retcode:=dpath(request,reply);
      reply[0]:=chr(ord(reply[3])+3);
      reply[3]:=chr(0);
      writeln('Return code is: ',retcode);
      writeln(reply);
    end;


(*************************************************************************)
(* Log request functions  *)
(**************************************************************************)

procedure SystemLog;
    var connection: integer;

    begin
      writeln('Get a Stations Logged Information');
          write('Enter the logical station number or connection number:  ');
      readln(connection);
      request:=chr(2)+chr(0)+chr(5)+chr(connection);
      reply:=chr(255)+chr(1);
      retcode:=syslog(request,reply);
      reply[0]:=chr(255);
      writeln('The return code is: ',retcode);
      writeln('The return string is: ');
      writeln(reply);
    end;


(************************************************************************)
(* Get the Date/Time String *)
(************************************************************************)

procedure GetTime;

    var time:str;
     begin
            retcode:=nettod(time);  { The value in the str is found at byte#-1 }
          writeln('The return code is: ',retcode);
            writeln('The month/day/year is: ',ord(time[1]),'/',ord(time[2]),'/',ord(time[0]));
            writeln('The time is: ',ord(time[3]),':',ord(time[4]),':',ord(time[5]));
            case ord(time[6]) of
           0:writeln('The day is Sunday');
           1:writeln('The day is Monday');
           2:writeln('The day is Tuesday');
           3:writeln('The day is Wednesday');
           4:writeln('The day is Thursday');
           5:writeln('The day is Friday');
           6:writeln('The day is Saturday');
          end;
     end;


(*************************************************************************)
(* Get the shell's Base Status *)
(*************************************************************************)

procedure driveHand;
    var drive: integer;

    begin
          write('Enter the drive number to check (A = 0, B = 1 etc.): ');
    readln(drive);
      retcode:=drvmap(drive);
      writeln('The network pathbase (drive handle) is: ',retcode);
    end;


(*************************************************************************)
(* Return the Shell Version *)
(*************************************************************************)

procedure RetShellVer;
    var envirstr: str;
        mode: integer;

    begin
      writeln('Enter the mode:');
    writeln('       0 - Find hardware type only');
      writeln('       1 - get the OS, version and hardware type');
      write('------>  ');
    readln(mode);
      if mode = 0 then
           begin
            retcode:=retshl(envirstr,mode);
            writeln('Hardware type is: ',retcode);
            writeln('The type is defined as follows: 0 - IBM PC, 1 - Victor 9000');
           end
      else
           begin
            retcode:=retshl(envirstr,mode);
            envirstr[0]:=chr(30);
            writeln(envirstr);
           end;
    end;


(*************************************************************************)
(* Log and/or Lock an ASCIIZ String *)
(*************************************************************************)

procedure AsciizStr;

    begin
      writeln('Choose one of the following:');
        writeln('         0 - Log or Lock the Asciiz string');
      writeln('         1 - Release an Asciiz string');
      writeln('         2 - Clear an Asciiz string');
      write('-------> ');
    readln(func);
      writeln;
      if func = 0 then
           begin
            writeln('Type a ''0'' if you only want to log the string');
        writeln('Type a ''1''if you want to log and lock the string');
        write('-------> ');
        readln(flag);
            write('Enter the string name: ');
        readln(asciiz);
            asciiz[length(asciiz)+1]:=chr(0);
            writeln(asciiz);
            write('Enter the desired timeout value in 1/18 second intervals: ');
        readln(TMO);
            writeln;
            retcode:=asclog(flag,TMO,asciiz);
            end
      else if func = 1 then
           begin
            write('Enter the name of the string to be released: ');
        readln(asciiz);
            asciiz[length(asciiz)+1]:=chr(0);   { Make an asciiz string }
            retcode:=asculkf(asciiz);
           end
      else if func = 2 then
           begin
            write('Enter the name of the string to be cleared: ');
        readln(asciiz);
            asciiz[length(asciiz)+1]:=chr(0);   {Make an asciiz string }
            retcode:=ascclrf(asciiz);
           end;
       writeln('The return code is: ',retcode);
    end;


(************************************************************************)
(* Get Physical station Number--switch setting on the Network Interface Card*)
(************************************************************************)

procedure GetPhsNum;

    begin
        retcode:=get_psn;
        writeln('The Physical Station Number is : ',retcode);
    end;


(************************************************************************)
(* Get the Shell table Addresses *)
(************************************************************************)

procedure GetShlAdr;

    begin
      writeln('Enter one of the following choices: ');
      writeln('         0 - Get the Drive Handle Table');
      writeln('         1 - Get the Drive Flag Table');
      writeln('         2 - Get the Drive Server Table');
      writeln('         3 - Get the Server Mapping Table');
      write('----->  ');
    readln(mode);
      retcode:=get_sta(mode,seg,off);
      writeln;
      writeln('These segment and offset addresses have been displayed in decimal');
      writeln;
      writeln('The segment address is: ',seg);
      writeln('The offset address is: ',off);
    end;


(************************************************************************)
(* Set the preferred File Server *)
(************************************************************************)

procedure PrefServ;

    begin
      writeln('Enter one of the following: ');
      writeln('        0 - Set the preferred file server');
      writeln('        1 - Get the preferred file server');
      writeln('        2 - Get the Effective File Server');
      writeln('        3 - Get the Spooled file server');
      writeln('        4 - Set the primary file server');
      writeln('        5 - Get the Primary file server');
      write('----->  ');
    readln(mode);
      writeln;
      write('Enter the preferred server 1-8:  ');
    readln(newserv);
      retcode:=setserv(mode,newserv);
      writeln('The return code is:  ',retcode);
    end;


(************************************************************************)
(* Attach or Detach to a file server *)
(************************************************************************)

procedure AttDetServ;

    begin
      writeln('Enter one of the following: ');
      writeln('       0 - Attach to a specfied server');
      writeln('       1 - Logout and detach from a specified server');
      writeln('       2 - Logout but do not detach from a specified server');
      write('----> ');
    readln(mode);
      writeln;
      write('Enter the specified server numbers 1-8: ');
    readln(newserv);
      writeln;
      retcode:=modserv(mode,newserv);
      writeln('The return code is: ',retcode);
    end;


(*************************************************************************)


procedure menu;
    var stop:boolean;

    begin
        repeat
            clrscr;
            stop:=false;
            hex:=' ';
            writeln('Choose one of the following: ');
            writeln('    0 - Get or Set the lock mode');
            writeln('    1 - OPEN a file');
            writeln('    2 - SET or Get a files attributes');
            writeln('    3 - Check the EOJ status');
            writeln('    4 - Log and Lock a record');
            writeln('    5 - Release a locked record');
            writeln('    6 - Lock a record set, all the records in the stations log table');
            writeln('    7 - Release a locked record set');
            writeln('    8 - Open a semaphore');
            writeln('    9 - Examine a semaphore');
            writeln('    A - Wait semaphore (decrement value) or Signal semaphore (increment value)');
            writeln('    B - Close a semaphore');
            writeln('    C - TTS Functions');
            writeln('    D - Begin or End logical locking read_modify_update cycle');
            writeln('    E - Logical locking functions');
            writeln('    F - Execute an End Of Job');
            writeln('    G - Logout');
            writeln('    Z - Quit');
            writeln;
            writeln('  ENTER A CORRESPONDING CHARACTER OR TYPE RETURN TO SEE THE REST OF THE MENU ');
            writeln('******************************************************************************');
            write('----> ');readln(ans);

            if NOT (ans IN ['0','1','2','3','4','5','6','7','8','9',
                    'a','b','c','d','e','f','g','z','A','B','C','D','E','F','G','Z']) then
                begin
                    clrscr;
                    writeln('H - Get the volume statistics');
                    writeln('I - Get the number of local drives');
                    writeln('J - Get the logical station number');
                    writeln('K - Set the error mode');
                    writeln('L - Set the broadcast mode');
                    writeln('M - Start the spooler under program control');
                    writeln('N - Various spooling functions');
                    writeln('O - Piping functions');
                    writeln('P - Directory Functions');
                    writeln('Q - Sytem log functions');
                    writeln('R - Get the Date/Time string');
                    writeln('S - Get the shells Base Status');
                    writeln('T - Get the shell version');
                    writeln('U - Log, Lock, Release and clear an Asciiz string.');
                    writeln('     Any Asciiz string function are assuming the Lock mode is 1');
                    writeln('V - Get the Physical Station Number');
                    writeln('W - Get the shell table addresses');
                    writeln('X - Get the preferred server, different functions');
                    writeln('Y - Attach or Detach a specified server');
                    writeln('Z - Quit');
                    writeln;
                    writeln('       ENTER A CORRESPONDING CHARACTER OR TYPE RETURN TO SEE MENU AGAIN...');
                    writeln('******************************************************************************');
                    write('------> ');readln(ans);
                end;

                clrscr;

                case ans of
                    '0':GetOrSet_LockMode;
                    '1':OPEN;
                    '2':SETGET;
                    '3':SetEOJ;
                    '4':Log_Lock;
                    '5':Rel_Clr;
                    '6':Lock_Set;
                    '7':Set_Rel_Clr;
                    '8':Sem_Open;
                    '9':Sem_Exam;
                    'a', 'A':Sem_Wait_Sig;
                    'b', 'B':Sem_Close;
                    'c', 'C':TTS_Functions;
                    'd', 'D':Logical_Begin_End;
                    'e', 'E':Logical_Locking;
                    'f', 'F':EndOfJob;
                    'g', 'G':Sys_logout;
                    'h', 'H':Get_Vol_Stat;
                    'i', 'I':Number_loc_drv;
                    'j', 'J':Logical_Sta_Num;
                    'k', 'K':SetErrorMode;
                    'l', 'L':Change_Bcast;
                    'm', 'M':Spool_Capture;
                    'n', 'N':Spool_Capture;
                    'o', 'O':Pipes;
                    'p', 'P':Directory;
                    'q', 'Q':SystemLog;
                    'r', 'R':GetTime;
                    's', 'S':DriveHand;
                    't', 'T':RetShellVer;
                    'u', 'U':AsciizStr;
                    'v', 'V':GetPhsNum;
                    'w', 'W':GetShlAdr;
                    'x', 'X':PrefServ;
                    'y', 'Y':AttDetServ;
                    'z', 'Z':stop:=true;
                end;

                if stop = FALSE then
                begin
                     writeln;writeln;
                 write('Type return to continue... ');readln;
                    end;
        until stop = true;
    end;



(**************************** MAIN PROGRAM ******************************)

    begin
        clrscr;
        writeln;writeln;writeln;writeln;
        writeln('                  SAMPLE FUNCTION CALL LIBRARY INTERFACE ');
        write('         please type return to continue... ');readln;
        writeln;
        explain;
        writeln;writeln;writeln;writeln;
        func:=1;
        retcode:=errmode(func);
        writeln('The ERROR MODE has been set to 1, to proceed type return');readln;writeln;
        menu;
    end.