home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / TURBOPAS / VALIDFIL.ZIP / VALIDFIL.BOX next >
Encoding:
Text File  |  1985-11-01  |  2.9 KB  |  113 lines
  1. type
  2.    NameString = String [40] ;
  3.  
  4. const
  5.    HighestValidDrive : Char = 'B' ;
  6.  
  7. function CheckFileName (Name : NameString) : Boolean ;
  8.  
  9. type
  10.    Valid = Set of Char ;
  11.  
  12. const
  13.    Colon = ':' ;
  14.    Period = '.' ;
  15.    FileChars : Valid = ['@'..'Z', '0'..'9', '!', '#'..')', '-', '_', '`', '{', '}'] ;
  16.    Blank = ' ' ;
  17.  
  18. type
  19.    GenStr = String [60] ;
  20.  
  21. var
  22.    NameChars : Valid ;
  23.    OK : Boolean ;
  24.    I : Byte ;
  25.    AllBlanks : Boolean ;
  26.  
  27.    procedure BlankStrip (var Str : NameString) ;
  28.  
  29.    var
  30.       I, J : Byte ;
  31.  
  32.    begin
  33.       repeat
  34.          for I := 1 to Length (Str) do if Str [I] = Blank then for J := (I + 1) to Length (Str) do Str [J - 1] := Str [J] ;
  35.       until Str [1] <> Blank ;
  36.       J := Length (Str) ;
  37.       if J > 14 then for I := J downto 14 do if Str [I] = Blank then Str := Copy (Str, 1, (I - 1)) ;
  38.    end ;
  39.  
  40.    procedure FormSet (var ChSet : Valid ; Name : NameString) ;
  41.  
  42.    var
  43.       I : 1..14 ;
  44.       Ch : Char ;
  45.  
  46.    begin
  47.       ChSet := [] ;
  48.       for I := 1 to Length (Name) do begin
  49.          Ch := Name[I] ;
  50.          ChSet := ChSet + [Ch] ;
  51.       end ;
  52.    end ;
  53.  
  54.  
  55.    procedure NameErr (var NameErr : Boolean ; Errms : GenStr) ;
  56.  
  57.    begin
  58.       NameErr := False ;
  59.       Writeln (Output) ;
  60.       Write (Output, ^G) ;
  61.       Writeln (Output, Errms) ;
  62.    end ;
  63.  
  64.    procedure ParseName (ChSet : Valid ; Name : NameString ; var Flag : Boolean) ;
  65.  
  66.    var
  67.       TStr : NameString ;
  68.  
  69.       procedure CheckExt (Name : NameString ; var Errf : Boolean) ;
  70.  
  71.       var
  72.          I, Len : Byte ;
  73.          MSvar : GenStr ;
  74.  
  75.       begin
  76.          I := Pos (Period, Name) ;
  77.          Len := Length (Name) ;
  78.          if ((Len - I) > 3) or (I > 9) then begin
  79.             if I > 9 then MSvar := 'name' else MSvar := 'extension' ;
  80.             NameErr (Errf, 'Invalid length, ' + MSvar) ;
  81.          end ;
  82.       end ;
  83.  
  84.    begin
  85.       Flag := True ;
  86.       if Colon in ChSet then begin
  87.          if Name[2] <> Colon then NameErr (Flag, 'Invalid drive specifier') ;
  88.          if not (Name[1] in ['A'..HighestValidDrive]) then NameErr (Flag, 'Drive specified not in system') ;
  89.          Tstr := Copy (Name, 3, 14) ;
  90.       end
  91.       else Tstr := Copy (Name, 1, 14) ;
  92.       if Period in ChSet then CheckExt (Tstr, Flag)
  93.       else if Length (Tstr) > 8 then NameErr (Flag, 'Invalid length, name') ;
  94.    end ;
  95.  
  96.  
  97. begin
  98.    AllBlanks := True ;
  99.    for I := 1 to Length (Name) do if Name [I] <> Blank then AllBlanks := False ;
  100.    if not AllBlanks then begin
  101.       BlankStrip (Name) ;
  102.       if Length (Name) > 14 then NameErr (OK, 'Input name string too long')
  103.       else begin
  104.          FileChars := FileChars + [Colon] + [Period] ;
  105.          FormSet (NameChars, Name) ;
  106.          if NameChars - FileChars <> [] then NameErr (OK, 'Invalid characters in name')
  107.          else ParseName (NameChars, Name, OK) ;
  108.       end ;
  109.    end
  110.    else NameErr (OK, 'Non-existent name, all blanks') ;
  111.    CheckFileName := OK ;
  112. end ;
  113.