Liren Large Software Subsidy 5/05.iso/a/a039/3.ddi/PASSAMP.ZIP/FONEDEX.PAS

Pascal/Delphi Source File | 1991-03-11 | 19.6 KB | 895 lines

{$N+,E+}
(*       Copyright (c) 1990 by Borland International, Inc. *)
program Fonedex;

uses
  CRT, PXEngine;
(*
 * FONEDEX.PAS
 * Simple electronic file card application
 *
 * Description:
 *   Allows simple database design and access of an electronic file
 *   card database. Records can be added, deleted, updated and searched
 *   in a multiuser environment.
 *
 *   The structure  of new tables is kept in the ASCII file
 *   STRUCTUREFILE. Each line of the file represents a field
 *   in the Paradox table DATAFILE. It has the format:
 *   <field type> <field name>
 *   where <field name> and <field type> are legal Paradox names and
 *   field types.
 *
 * Complilation:
 *   To compile and link the example program, make sure that your
 *   Turbo Pascal compiler (version 5.5 or 6.0) has been correctly
 *   installed.
 *
 * Execution:
 *   To run the example program enter the following command:
 *     fonedex
 *   You can then choose different options through a very simple menu
 *   interface.
 *)

const
  SUCCESS = True;
  FAILURE = False;
  MAXFIELDS = 20;
  MAXFIELDSIZE = 50;
  StructureFile = 'fonedex.dat';
  DataFile = 'fonedex';

  (* Constants for PXNetInit (modify these constants to match your network) *)

  UserName = 'Engine';
  NetType = NOTONNET;
  NetDir = '';

var
  RecHandle: RecordHandle;              (* record buffer *)
  TblHandle: TableHandle;               (* table handle *)
  Names,                                (* field names *)
   Types: NamesArrayPtr;                (* field types *)
  TableIsOpen: Boolean;                 (* flag for open Table *)
  NFields: Integer;                     (* number of fields *)

(*
 *    Procedure:
 *          Strip
 *
 *    Arguments:
 *          S       String to be stripped of white space.
 *
 *    Description:
 *          Strips a string of leading and trailing white space.
 *)
procedure Strip(var S: String );

  var
    L1, L2: Byte;

  begin
    L1 := 1;
    while (L1 < Length(S)) and (S[L1] in [#9..#13, ' ']) do
      Inc(L1);
    L2 := Length(S);
    while (L2 > 0) and (S[L2] in [#9..#13, ' ']) do
      Dec(L2);
    S := Copy(S, L1, L2 - L1 + 1);
  end; (* Strip *)


(*
 *    Function:
 *      Error
 *
 *    Arguments:
 *        RC                  return code from a PX... function
 *
 *    Description:
 *        Writes error message if an error has occurred.
 *
 *    Returns:
 *      True if Error
 *      else False
 *)
function Error(RC: Integer): Boolean;

  begin
    if RC <> PXSUCCESS then
      WriteLn('FONEDEX: ', PXErrMsg(RC));
    Error := RC <> PXSUCCESS;
  end; (* Error *)


(*
 *    Procedure:
 *      ErrIgnore
 *
 *    Arguments:
 *        RC                  return code from a PX... function
 *
 *    Description:
 *        Writes error message if an error has occurred.
 *
 *    Returns:
 *      None
 *)
procedure ErrIgnore(RC: Integer);

  begin
    if Error(RC) then; (* ignore error return code *)
  end; (* ErrIgnore *)


(*
 *    Function:
 *          LoadTableStructure
 *
 *    Arguments:
 *          None
 *
 *    Description:
 *          Loads a table structure from an ASCII disk file.
 *
 *    Returns:
 *          SUCCESS     structure loaded
 *          FAILURE     error occurred
 *)
function LoadTableStructure: Boolean;

  var
    F: Text;
    FldName, FldType, Help: String;

  begin
    (* Open the structure file *)

    Assign(F, StructureFile);
{$I-}
    Reset(F);
{$I+}
    if IoResult <> 0 then
      begin
        WriteLn('can''t open Structure file');
        LoadTableStructure := FAILURE;
        Exit;
      end;
    (* Read in the structure *)
    NFields := 0;
    New(Names);
    New(Types);

    while not Eof(F) and (NFields < MAXFIELDS) do

      begin

        (* read data, bewaring of unexpected EOF *)
{$I-}
        ReadLn(F, Help);
{$I+}
        if (IoResult = 0) and (Help <> '') then
          begin

            Inc(NFields);
            Strip(Help);
            FldType := Copy(Help, 1, Pos(' ', Help) - 1);
            FldName := Copy(Help, Pos(' ', Help), Length(Help));
            (* remove trailing and leading white space from name *)
            Strip(FldName);
            Names^[NFields] := FldName;
            Types^[NFields] := FldType;

          end; (* THEN *)
      end; (* WHILE *)

    Close(F);
    (* Return error if no fields were found *)
    if NFields = 0 then
      LoadTableStructure := FAILURE
    else
      LoadTableStructure := SUCCESS;

  end; (* LoadTableStructure *)


(*
 *   Procedure:
 *          FreeTableStructure
 *
 *    Arguments:
 *          None
 *
 *    Description:
 *          Frees memory associated with table structure
 *
 *    Returns:
 *          None
 *)

procedure FreeTableStructure;

  begin
    Dispose(Names);
    Dispose(Types);
  end; (* FreeTableStructure *)


(*
 *    Procedure:
 *          NewFonedex
 *
 *    Arguments:
 *          None
 *
 *    Description:
 *          Create a new fonedex database. The structure of this data
 *          base is read in from an ASCII disk file.
 *
 *    Returns:
 *          None
 *)
procedure NewFonedex;

  begin
    (* First load the structure of the table from an ASCII data file *)

    if LoadTableStructure = FAILURE then
      WriteLn('FONEDEX: Cannot load table structure')
    else (* try and create it *)
    if not Error(PXTblCreate(DataFile, NFields, Names, Types)) then (* Free up
                                        the table structure *)
      FreeTableStructure;

  end; (* NewFonedex *)


(*
 *    Function:
 *          GetTableStructure
 *
 *    Arguments:
 *          None
 *
 *    Description:
 *          Retrieves table field names and types.
 *
 *    Returns:
 *          SUCCESS     structure loaded
 *          FAILURE     error occurred
 *)

function GetTableStructure: Boolean;

  var
    FldName, FldType: NameString;
    I: Word;

  begin

    NFields := 0;
    New(Names);
    New(Types);

    if Error(PXRecNFlds(TblHandle, NFields)) then; (* ignore Result *)
    for I := 1 to NFields do

      if not Error(PXFldName(TblHandle, I, FldName)) and
         not Error(PXFldType(TblHandle, I, FldType)) then
        begin
          Names^[I] := FldName;
          Types^[I] := FldType;
        end
      else
        begin
          GetTableStructure := FAILURE;
          Exit;
        end;
    GetTableStructure := SUCCESS;

  end; (* GetTableStructure *)


(*
 *    Procedure:
 *          OpenFonedex
 *
 *    Arguments:
 *          None
 *
 *    Description:
 *          Opens the fonedex table
 *
 *    Returns:
 *          None
 *)
procedure OpenFonedex;

  begin
    (* Attempt to open the table and allocate a record buffer. If table
       is open, inidicate an error *)

    if TableIsOpen then
      begin
        WriteLn('table already opened');
        Exit;
      end;
    (* Now try and open the table *)
    if Error(PXTblOpen(DataFile, TblHandle, 0, False)) then
      Exit;

    (* Allocate a record buffer *)

    if Error(PXRecBufOpen(TblHandle, RecHandle)) then
      Exit;
    if GetTableStructure = FAILURE then
      Exit;
    TableIsOpen := True;

  end; (* OpenFonedex *)


(*
 *    Procedure:
 *          CloseFonedex
 *
 *    Arguments:
 *          None
 *
 *    Description:
 *          Closes the fonedex table if opened
 *
 *    Returns:
 *          None
 *)
procedure CloseFonedex;

  begin

    if not TableIsOpen then
      begin
        WriteLn('table not open');
        Exit;
      end;
    (* Free the record buffer *)
    if Error(PXRecBufClose(RecHandle)) then
      Exit;

    (* Close the table *)

    if Error(PXTblClose(TblHandle)) then
      Exit;
    FreeTableStructure;
    TableIsOpen := False;

  end; (* CloseFonedex *)


(*
 *    Function:
 *          GetData
 *
 *    Arguments:
 *          FH       field number to retrieve data
 *          S        string where data is stored
 *
 *    Description:
 *          Retrieves in a string format any valid Paradox type.
 *
 *    Returns:
 *          SUCCESS  No errors retrieving data
 *          FAILURE  Error retrieving data
 *)

function GetData(FH: FieldHandle;
                 var S: String ): Boolean;


  var
    TheDate: TDate;
    Month, Day, Year: Integer;
    TheValue: Double;
    TheShort: Integer;
    IsBlank: Boolean;
    Help: String ;

  begin
    (* if this field is blank, we want to return a blank string *)

    GetData := SUCCESS;
    if not Error(PXFldBlank(RecHandle, FH, IsBlank)) then
      if IsBlank then
        S := ''

      else
        case UpCase(Types^[FH][1]) of
          'A':
            if Error(PXGetAlpha(RecHandle, FH, S)) then
              GetData := FAILURE;
          'D':
            if not Error(PXGetDate(RecHandle, FH, TheDate)) then
              begin
                ErrIgnore(PXDateDecode(TheDate, Month, Day, Year));
                Str(Month, S);
                Str(Day, Help);
                S := S + '/' + Help;
                Str(Year, Help);
                S := S + '/' + Help;
              end
            else
              GetData := FAILURE;
          'N':
            if not Error(PXGetDoub(RecHandle, FH, TheValue)) then
              Str(TheValue: 5: 0, S)
            else
              GetData := FAILURE;
          '$':
            if not Error(PXGetDoub(RecHandle, FH, TheValue)) then
              Str(TheValue: 6: 2, S)
            else
              GetData := FAILURE;
          'S':
            if not Error(PXGetShort(RecHandle, FH, TheShort)) then
              Str(TheShort, S)
            else
              GetData := FAILURE;
        end (* case *)
    else
      GetData := FAILURE; (* an error occured in PXFldBlank *)

  end; (* GetData *)


(*
 *    Function:
 *          PutData
 *
 *    Arguments:
 *          FieldNumber             field number to store data
 *          S                       string to be stored
 *
 *    Description:
 *          Stores a string in any valid Paradox type.
 *
 *    Returns:
 *          SUCCESS  No errors storing data
 *          FAILURE  Error storing data
 *)

function PutData(FH: FieldHandle;
                 S: String ): Boolean;

  var
    TheDate: TDate;
    Month, Day, Year: Integer;
    TheValue: Double;
    TheShort: Integer;
    Code: Integer;                      (* needed for VAL *)



  function GetNextWVal(var S: String ): Word;

    const
      Delim = '/';

    var
      L: Byte;
      Help: Word;
      Code: Integer;

    begin
      L := Pos(Delim, S);
      if L = 0 then
        L := Length(S) + 1;
      Val(Copy(S, 1, L - 1), Help, Code);
      S := Copy(S, L + 1, Length(S));
      if Code = 0 then
        GetNextWVal := Help
      else
        GetNextWVal := 0;
    end; (* GetNextWVal *)
  begin

    PutData := SUCCESS;
    case UpCase(Types^[FH][1]) of
      'A':
        if Error(PXPutAlpha(RecHandle, FH, S)) then
          PutData := FAILURE;
      'D':
        begin
          Month := GetNextWVal(S);
          Day := GetNextWVal(S);
          Year := GetNextWVal(S);
          if Error(PXDateEncode(Month, Day, Year, TheDate)) or
             Error(PXPutDate(RecHandle, FH, TheDate)) then
            PutData := FAILURE;
        end;
      '$', 'N':
        begin
          Val(S, TheValue, Code);
          if Error(PXPutDoub(RecHandle, FH, TheValue)) then
            PutData := FAILURE;
        end;
      'S':
        begin
          Val(S, TheShort, Code);
          if Error(PXPutShort(RecHandle, FH, TheShort)) then
            PutData := FAILURE;
        end;

    end; (* case *)
  end; (* PutData *)


(*
 *    Function:
 *          InputRecord
 *
 *    Arguments:
 *          None
 *
 *    Description:
 *          Allows editing of an existing record buffer and lets
 *          user accept, cancel, or re-edit.
 *
 *    Returns:
 *          SUCCESS     User accepts changes
 *          FAILURE     Changes declined
 *)
function InputRecord: Boolean;

  var
    C: Char;
    I: Word;
    Buf: String ;

  begin
    InputRecord := FAILURE;
    (* Keep attempting to input until user selects DONE or CANCEL *)

    while True do
      begin
        (* Go through all fields *)
        for I := 1 to NFields do
          begin
            (* translate the current value into the input buffer *)
            if GetData(I, Buf) <> SUCCESS then
              Exit;

            WriteLn(Buf);
            (* ask for the new value *)
            Write(Names^[I], ': ');
            ReadLn(Buf);

      (* Now translate it back into the record buffer unless old value
         is kept by just hitting return. *)

            if Length(Buf) > 0 then
              if PutData(I, Buf) <> SUCCESS then
                Exit;

          end; (* for *)
        (* Ask what to do with this input *)

        WriteLn('S)ave, C)ancel, R)edo:');
        repeat
          C := UpCase(ReadKey);
        until C in ['S', 'C', 'R'];
        case C of
          'S':
            begin
              InputRecord := SUCCESS;
              Exit;
            end;
          'C': Exit;
        end; (* case *)

      end; (* while *)
  end; (* InputRecord *)


(*
 *    Procedure:
 *          AddEntry
 *
 *    Arguments:
 *          None
 *
 *    Description:
 *          Add a new record to the fonedex table
 *
 *    Returns:
 *          None
 *)
procedure AddEntry;

  begin

    if not TableIsOpen then
      begin
        WriteLn('Table not opened');
        Exit;
      end;
    (* Empty the current record buffer *)
    if Error(PXRecBufEmpty(RecHandle)) then
      Exit;

    (* get the fields unless input is cancelled by user *)
    if InputRecord = FAILURE then
      Exit;
    (* Attempt to append the record *)
    ErrIgnore(PXRecAppend(TblHandle, RecHandle));

  end; (* AddEntry *)


(*
 *    Function:
 *          InputField
 *
 *    Arguments:
 *          FieldNumber          Field number selected
 *
 *    Description:
 *          Displays and accepts a legal field number
 *
 *    Returns:
 *          SUCCESS              valid field number entered
 *          FAILURE              invalid field number entered
 *)
function InputField(var FieldNumber: FieldHandle): Boolean;

  var
    Buf: String ;

  begin
    (* Get the field number as an integer *)

    FieldNumber := Ord(ReadKey) - Ord('0');
    if (FieldNumber < 1) or (FieldNumber > NFields) then
      begin
        WriteLn('illegal field number');
        InputField := FAILURE;
        Exit;
      end;

    (* Input the field *)

    Write(Names^[FieldNumber], ': ');
    ReadLn(Buf);
    (* And translate it *)
    if PutData(FieldNumber, Buf) <> SUCCESS then
      begin
        InputField := FAILURE;
        Exit;
      end;
    InputField := SUCCESS;

  end; (* InputField *)


(*
 *    Procedure:
 *          SearchUpdate
 *
 *    Arguments:
 *          None
 *
 *    Description:
 *          Edits and Updates the currently selected record.    Record
 *          locking is used to stop multiple updates.
 *
 *    Returns:
 *          None
 *)
procedure SearchUpdate;

  var
    LckHandle: LockHandle;

  begin
    (* Lock the record *)

    if not Error(PXNetRecLock(TblHandle, LckHandle)) then (* Edit the record *)
      begin
        if InputRecord <> FAILURE then (* Update it *)
          if PXRecUpdate(TblHandle, RecHandle) <> PXSUCCESS then
            Exit;
        (* And unlock it *)
        ErrIgnore(PXNetRecUnlock(TblHandle, LckHandle));
      end;

  end; (* SearchUpdate *)


(*
 *    Procedure:
 *          ProcessSearch
 *
 *    Arguments:
 *          FieldNumber             field number to search on
 *
 *    Description:
 *          Performs actual search on given field.    Allows user to
 *          Delete and Update records.
 *
 *    Returns:
 *          None
 *)
procedure ProcessSearch(FieldNumber: FieldHandle);

  var
    Mode: Integer;
    I: Integer;
    Done: Boolean;
    Buf: String ;

  begin
    Mode := SEARCHFIRST;
    Done := True;

    while True do
      begin
        (* If no match found, get out *)
        if PXSrchFld(TblHandle, RecHandle, FieldNumber,
           Mode) <> PXSUCCESS then
          begin
            WriteLn('No Matches');
            Exit;
          end;

        (* Get the record found *)

        if Error(PXRecGet(TblHandle, RecHandle)) then
          Exit;
        (* Print the record *)
        for I := 1 to NFields do
          begin
            if GetData(I, Buf) <> SUCCESS then
              Exit;
            WriteLn(Names^[I], ': ', Buf);
          end;

        WriteLn('N)ext, D)elete, U)pdate, E)xit Search:');
        repeat
          case UpCase(ReadKey) of
            'N':
              begin (* Search for the next occurrence *)
                Mode := SEARCHNEXT;
                Done := True;
              end;
            'D':
              begin
                ErrIgnore(PXRecDelete(TblHandle));
                Exit;
              end;
            'U':
              begin
                SearchUpdate;
                Exit;
              end;
            'E': Exit;
            else Done := False;
          end; (* case *)
        until Done;
      end; (* while *)

  end; (* ProcessSearch *)


(*
 *    Procedure:
 *          Search
 *
 *    Arguments:
 *          None
 *
 *    Description:
 *          Search functions
 *
 *    Returns:
 *          None
 *)
procedure Search;

  var
    FieldNumber, I: Word;

  begin
    (* Make sure table is opened *)

    if not TableIsOpen then
      begin
        WriteLn('table not open');
        Exit;
      end;
    (* Refresh the database in case anyone else has updated it *)
    ErrIgnore(PXNetTblRefresh(TblHandle));

    (* List the fields to search on *)

    WriteLn('Select Field');
    for I := 1 to NFields do
      WriteLn(I, ' ', Names^[I]);
    (* Get the input field to search on *)
    if InputField(FieldNumber) = FAILURE then
      Exit;
    (* Perform Search Options *)
    ProcessSearch(FieldNumber);

  end; (* Search *)


(*
 *  Procedure:
 *    Menu
 *
 *  Arguments:
 *    None
 *
 *  Description:
 *    Displays a menu structure, gets a valid menu response
 *    and dispatches to the appropriate function.
 *
 *  Returns:
 *    None
 *
 *)
procedure Menu;

  var
    C: Char;

  begin

    repeat
      WriteLn;
      WriteLn('Main Menu');
      WriteLn('   1  -  New Fonedex');
      WriteLn('   2  -  Open Fonedex');
      WriteLn('   3  -  Close Fonedex');
      WriteLn('   4  -  Add Entry');
      WriteLn('   5  -  Search');
      WriteLn('   6  -  Quit');
      C := ReadKey;

      case C of
        '1': NewFonedex;
        '2': OpenFonedex;
        '3': CloseFonedex;
        '4': AddEntry;
        '5': Search;
        '6': ; (* Do nothing *)
        else WriteLn('Invalid option.');
      end; (* case *)
    until C = '6';

  end; (* menu *)


(*
 * Description:
 *   Initializes the Engine and calls the main menu
 *   When the main menu returns, the table is closed
 *   if it was left open.
 *)

begin
  TableIsOpen := False; (* table is not open *)
  (* Initialize the Engine *)
  if Error(PXNetInit(NetDir, NetType, UserName)) then
    Halt(1);
  (* Menu loop *)
  Menu;
  (* Close table if open *)

  if TableIsOpen then
    CloseFonedex;
  (* Terminate the Engine *)
  if Error(PXExit) then
    Halt(1);

end.