[Back to FILES SWAG index] [Back to Main SWAG index] [Original]

    {
    Hi,
      here's another contribution - an LFN unit which is actually useful. It
    allows working with near-normal TP/TPW commands, transparently on LFN
    and non-LFN disks. Enjoy.

    Eyal Doron
    }

    {$IFDEF WINDOWS}
    {$N-,V-,W-,G+}
    {$ELSE}
    {N-,V-,G+}
    {$ENDIF}

    Unit lfnunit;

    {========================================================================}
    { LFNUnit - A long filename support unit for TP6 and TPW1.5.             }
    { Written by Eyal Doron, doron@physics,technion.ac.il, June 1997.        }
    { Released into the public domain.                                       }
    {                                                                        }
    { This is a unit to support long filenames in Win95 and WinNT, for use   }
    { in ordinary 16-bit programs in Turbo Pascal 6.0 and Turbo Pascal for   }
    { Windows 1.5. It should be a simple matter to adapt to TP/BP 7 as well. }
    { The unit is built to support LFN if available, and the usual FAT16     }
    { format if not, in a transparent manner, i.e. the programmer should not }
    { worry whether LFN is supported or not, the routines work the same in   }
    { both cases. The unit is not complete, in the sense that not all of the }
    { interrupts are supported, but the main thrust is the enhancement of    }
    { the Turbo Pascal I/O scheme to support LFN in as natural a way as      }
    { possible.                                                              }
    {                                                                        }
    { The unit contains three families of procedures and functions:          }
    { 1) Basic LFN API: This is a set of procedures and functions that give  }
    {    access to the LFN interrupts: FindFirst/Next/Close, short and long  }
    {    names, time, attributes and creation.                               }
    { 2) Service routines. These routines make use of the LFN API to mimic   }
    {    the operation of the DOS or WinDos supplied routines, only with LFN }
    {    support. I chose to mimic the TP6.0 routines, rather than the TPW   }
    {    ones, because I prefer Pascal-type strings to C-type strings, but   }
    {    its a simple matter to add these as well. All the routines return   }
    {    their error codes inside the DOS/WinDos global "DosError".          }
    { 3) Input-output support. This set of procedures and functions defines  }
    {    the paradigm for LFN support in Turbo Pascal. It "rides" on top of  }
    {    the usual file variables ("file", "file of" and "text"), and stores }
    {    the additional LFN info in the UserData field of the file records.  }
    {    The routines have an interface which is similar to the TP ones,     }
    {    namely "LFNAssign" is equivalent to "Assign", "LFNRewrite" to       }
    {    "Rewrite", and so on. This paradigm enables use of the usual Pascal }
    {    I/O scheme and routines with long file names, in an almost          }
    {    transparent manner. The differences are:                            }
    {    a) Before using a file variable it has to be initialized by calling }
    {       LFNNew. After you are done with it, you should call LFNDispose   }
    {       to free the allocated memory.                                    }
    {    b) You MUST consistently use LFNNew, LFNAssign, LFNRewrite,         }
    {       LFNRename and LFNDispose in order to support LFN. The other      }
    {       routines are optional, providing error detection and consistent  }
    {       error trapping, but the TP equivalents should also work.         }
    {    c) LFNReset, LFNRewrite and LFNAppend always accept a RecLen        }
    {       parameter, which is optional in Reset and Rewrite and missing in }
    {       Append. This is because TP does not support overloading. The     }
    {       parameter is ignored for text files and when it is zero.         }
    {    d) LFNAppend differs from Append also in that if the file does not  }
    {       exist, Append reports a DOS error, while LFNAppend creates it    }
    {       using LFNRewrite.                                                }
    {    e) LFNFindFirst/LFNFindNext return the name as an AsciiZ string,    }
    {       not a Pascal string, even in TP6, for the sake of consistency.   }
    {    f) All the routines return the error code in the DosError global    }
    {       Dos/WinDos variable, and most of them also return it as a        }
    {       functional result. Additionally, the "LFNRuntimeErrors" global   }
    {       boolean variable controls the generation of runtime errors.      }
    {                                                                        }
    { Comments, bug reports, etc. are welcome.                               }
    {========================================================================}

    Interface

    Uses
    {$IFDEF WINDOWS}
      WinDos,WObjects,WinTypes,WinProcs,strings;
    {$ELSE}
      Dos,Objects;
    {$ENDIF}

    const
      ShortPathName = 79;
      LFNRuntimeErrors: boolean = false; { Determines if runtime errors are generated }

      LFNErr_Uninitialized = 120; { LFN routines called before LFNAssign }
      LFNErr_NotAllocated  = 121; { LFN routines called before LFNNew    }
      LFNErr_NotATextFile  = 122; { Appending to a non-text file         }

    {$IFDEF WINDOWS}
      ofn_LongNames = $00200000;  { Required to support LFN in the common dialogs. }
                                  { OR it into the Flags record of TOpenFilename.  }
    {$ENDIF}

    type
      ShortPathStr = string[ShortPathName];
    {$IFNDEF WINDOWS}
      TSearchRec = SearchRec;
      TDateTime = DateTime;
      PChar = ^Char;
    {$ENDIF}

      TLFNSearchRec = record
        Attr         : longint;
        Creation     : comp;
        LastAccess   : comp;
        LastMod      : comp;
        HighFileSize : longint; { high 32 bits }
        Size         : longint; { low 32 bits  }
        Reserved     : comp;
        Name         : array[0..259] of char;
        ShortName    : array[0..13] of char;
        Handle       : word;
      end;
      PLFNSearchRec = ^TLFNSearchRec;
      { Form used for old-style searches, with an embedded TSearchRec }
      TLFNShortSearchRec = record
        Attr         : longint;
        Creation     : comp;
        LastAccess   : comp;
        LastMod      : comp;
        HighFileSize : longint;
        Size         : longint;
        Reserved     : comp;
        Name         : array[0..13] of char;
        SRec         : TSearchRec;
        Filler       : array[1..260-14-sizeof(TSearchRec)] of byte;
        ShortName    : array[0..13] of char;
        Handle       : word;
      end;
      PLFNShortSearchRec = ^TLFNShortSearchRec;

      { A record to isolate the UserData parameters }
      TLFNFileParam = record
        Handle     : word;                   { The file handle                  }
        Mode       : word;                   { The file mode                    }
        Res1       : array[1..28] of byte;   { Everything else up to UserData   }
        { Begin UserData }
        lfname     : PString;                { The long filename in String form }
        plfname    : PChar;                  { The long filename in AsciiZ form }
        TextFile   : boolean;                { Is it a text or binary file      }
        Initialized: boolean;                { Has it been LFNAssigned          }
        Magic      : string[3];              { ID to check LFNNew               }
        Res2       : array[0..1] of byte;    { 2 bytes left in UserData         }
        { End UserData }
        SName      : array[0..79] of char;   { The short filename               }
      end;
      PLFNFileParam = ^TLFNFileParam;

    var
      LFNAble: boolean;   { Is LFN supported or not. Upon startup it is determined }
                          { by the OS, but can be switched off later if need be.   }

    function LFNToggleSupport(on: boolean): boolean;

    {$IFNDEF WINDOWS}
    { I need these to access the Srec.Name field properly }
    function PCharOf(var F): Pchar;
    function StrPas(P: PChar): string;
    {$ENDIF}

    function PChar2Pstring(F: Pchar): PString;
    function PString2PChar(F: Pstring): PChar;

    { Basic API calls }
    function  LFNTimeToDos(var LTime: comp): longint;
    function  DosTimeToLFN(var Time: longint; var LTime: comp): word;
    function  LGetAttr(Filename: PChar; var Attr: word): word;
    function  LRenameFile(FromName,ToName: PChar): word;
    function  LCreateEmpty(fname: PChar): word;
    function  LFNFindFirst(filespec: string; attr: word; var S: TLFNSearchRec): word;
    function  LFNFindNext(var S: TLFNSearchRec): word;
    function  LFNFindClose(var S: TLFNSearchRec): word;
    function  LFNShortName(LongName: string): ShortPathStr;
    function  LFNLongName(ShortName: ShortPathStr): string;

    { Service routines }
    procedure LFNUnpackTime(var LTime: comp; var DT: TDateTime);
    function  LFNGetFAttr(var F; var Attr: word): integer;
    function  LFNFileExist(fname: string): boolean;
    function  LFNFSearch(Path,DirList: string): string;
    procedure LFNFSplit(Path: string; Dir,Name,Ext: PString);
    function  LFNFExpand(Path: string): string;
    procedure CanonicalFname(var S: string);
    function  CanonicalFilename(Fname: PChar): Pchar;

    { Interface to the Pascal Input/Output routines }
    procedure LFNNew    (var F; IsText: boolean);
    function  LFNAssign (var F; name: string): integer;
    function  LFNRewrite(var F; RecLen: word): integer;
    function  LFNAppend (var F; RecLen: word): integer;
    function  LFNReset  (var F; RecLen: word): integer;
    function  LFNErase  (var F): integer;
    function  LFNClose  (var F): integer;
    procedure LFNDispose(var F);
    function  LFNRename (var F; NewName: string): integer;

    implementation

    const
    {$IFNDEF WINDOWS}
      faReadOnly      =  ReadOnly;
      faHidden        =  Hidden;
      faSysFile       =  SysFile;
      faVolumeID      =  VolumeID;
      faDirectory     =  Directory;
      faArchive       =  Archive;
      faAnyFile       =  AnyFile;
    {$ENDIF}

      LFNMagic = 'LFN';

    type
      PSearchRec = ^TSearchRec;
      TByteArray = array[0..$FFF0-1] of char;
      PByteArray = ^TByteArray;

    {$IFNDEF WINDOWS}
    function PCharOf(var F): Pchar;
    { A very simple function which returns a pointer to its argument. }
    { Its main use is in turning array[...] of char in to PChar, to   }
    { simulate the TPW/TP7/BP7 extended syntax.                       }
    begin
      PCharOf:=@F;
    end;

    function StrPas(P: PChar): string;
    var
      i: integer;
      tmp: PString;
    begin
      New(tmp); tmp^:=''; if P=Nil then Exit;
      i:=0;
      while (length(tmp^)<256) and (PByteArray(P)^[i]<>#0) do
      begin
        tmp^:=tmp^+PByteArray(P)^[i]; inc(i);
      end;
      StrPas:=tmp^; Dispose(tmp);
    end;

    function StrLen(P: PChar): integer;
    var
      i: integer;
    begin
      i:=0;
      if P<>Nil then while (i<$7FFF) and (PByteArray(P)^[i]<>#0) do inc(i);
      StrLen:=i;
    end;
    {$ENDIF}

    function PChar2Pstring(F: Pchar): PString;
    { This routine changes a PChar (AsciiZ) string to a }
    { Pascal-type string, in the same memory location.  }
    var
      i,len: integer;
    begin
      len:=StrLen(F); if len>255 then len:=255;
      for i:=len downto 1 do PByteArray(F)^[i]:=PByteArray(F)^[i-1];
      F^:=Chr(len);
      PChar2PString:=PString(F);
    end;                   { PChar2Pstring }

    function PString2PChar(F: Pstring): PChar;
    { This routine changes a Pascal-type string to an }
    { AsciiZ string, in the same memory location.     }
    var
      i,len: integer;
    begin
      len:=length(F^);
      for i:=1 to len do F^[i-1]:=F^[i]; F^[len]:=#0;
      PString2PChar:=PChar(F);
    end;                 { PString2PChar }

    {$IFDEF WINDOWS}
    function SupportsLFN: boolean;
    var
      WinVersion: word;
    begin
    {  SupportsLFN:=false; Exit;}
      WinVersion := LoWord(GetVersion);
      SupportsLFN:=true;
      If ((Lo(WinVersion) =  3)  and                    {windows 95 first}
          (Hi(WinVersion) < 95)) or                     {version is 3.95 }
          (Lo(WinVersion) <  3)  then SupportsLFN := False;
    end;
    {$ELSE}
    function SupportsLFN: boolean; assembler;
    asm
      mov ax, $160a
      int $2f
      cmp ax, 0
      jne @no         { Not running under Windows   }
      cmp bh, 2
      jle @no         { Major version <3            }
      cmp bh, 4
      jge @yes        { Major version >3            }
      cmp bl, 94
      jle @no         { Major version =3, minor <95 }
    @yes:
      mov al, true
      jmp @exit
    @no:
      mov al, false
    @exit:
    end;                 { SupportsLFN }
    {$ENDIF}

    function LFNToggleSupport(on: boolean): boolean;
    { This routine toggles LFN support on and off, provided }
    { the OS supports it. It returns the previous status.   }
    begin
      LFNToggleSupport:=LFNAble;
      LFNAble:=on and SupportsLFN;
    end;

    {==============================================================}
    { BASIC LFN API CALLS.                                         }
    { This is a set of routines which implement the WIn95 LFN API, }
    { in Turbo Pascal form.                                        }
    {==============================================================}

    function LFNTimeToDos(var LTime: comp): longint; assembler;
    { Convert 64-bit number of 100ns since 01-01-1601 UTC to local DOS format time}
    { (LTime is var to avoid putting it on the stack) }
    asm
      push ds
      lds si,LTime
      xor bl,bl
      mov ax,71a7h
      int 21h
      pop ds
      mov ax,cx
      cmc
      sbb cx,cx
      and ax,cx
      and dx,cx
    end;                { LFNTimeToDos }

    function DosTimeToLFN(var Time: longint; var LTime: comp): word;
    { Convert DOS time to the 64-bit Win95 format }
    var
      DosTime,DosDate: word;
      DT: TDateTime;
    begin
      UnpackTime(Time,DT); FillChar(LTime,sizeof(LTime),0);
      with DT do
      begin
        DosTime:=(sec div 2) or (min shl 5) or (hour shl 11);
        DosDate:=day or (Month shl 5) or ((Year-1980) shl 9);
      end;
      asm
        mov ax, $71A7
        mov bl, 1
        mov cx, DosTime
        mov dx, DosDate
        mov bh, 0
        les di, LTime
        int $21
        jnc @1
        mov [DosError],ax
    @1:
      end;
      DosTimeToLFN:=DosError;
    end;                 { DosTimeToLFN }

    function LGetAttr(Filename: PChar; var Attr: word): word; assembler;
    { Get the attributes of a file, PChar syntax }
    asm
      push ds
      lds dx,Filename
      mov ax,7143h
      xor bl,bl
      int 21h
      pop ds
      les di,Attr
      mov es:[di],cx
      sbb bx,bx
      and ax,bx
      mov [DosError],ax
    end;                      { LGetAttr }

    function LFindFirst(FileSpec: pchar; Attr: word; var SRec: TLFNSearchRec): word;
    assembler;
    { Search for files }
    asm
      push ds
      lds dx,FileSpec
      les di,SRec
      mov cx,Attr
      xor si,si
      mov ax,714eh
      int 21h
      pop ds
      sbb bx,bx
      mov es:[di].TLFNSearchRec.Handle,ax
      and ax,bx
      mov [DosError],ax
    end;

    function LFindNext(var SRec: TLFNSearchRec): word; assembler;
    { Find next file }
    asm
      mov ax,714fh
      xor si,si
      les di,SRec
      mov bx,es:[di].TLFNSearchRec.Handle
      int 21h
      sbb bx,bx
      and ax,bx
      mov [DosError],ax
    end;

    function LFindClose(var SRec: TLFNSearchRec): word; assembler;
    { Free search handle }
    asm
      mov ax,714fh
      mov bx,es:[di].TLFNSearchRec.Handle
      int 21h
      sbb bx,bx
      and ax,bx
      mov [DosError],ax
    end;

    function LGetShortName(FileName: pchar; Result: pchar): word; assembler;
    { Return complete short name/path for input file/path in buffer }
    { Result (79 bytes) }
    asm
      push ds
      lds si,FileName
      les di,Result
      mov ax,7160h
      mov cx,1
      int 21h
      pop ds
      sbb bx,bx
      and ax,bx
      mov [DosError],ax
    end;

    function LGetLongName(FileName: PChar; Result: PChar): word; assembler;
    { Return complete long name/path for input file/path in buffer }
    { Result (261 bytes) }
    asm
      push ds
      lds si,FileName
      les di,Result
      mov ax,7160h
      mov cx,2
      int 21h
      pop ds
      sbb bx,bx
      and ax,bx
      mov [DosError],ax
    end;

    function LRenameFile(FromName,ToName: PChar): word; assembler;
    { Rename a file, supports long filenames. }
    asm
      push ds
      mov ax, $7156
      lds dx, FromName
      les di, ToName
      int $21
      jc @1
      mov ax, 0
    @1:
      pop ds
      mov [DosError],ax
    end;           { LRenameFile }

    function LCreateEmpty(fname: PChar): word; assembler;
    { Create an empty file with the given (long) name. }
    asm
      push ds
      mov ax, $716C
      mov bx, 000010b     { Open long file name for writing }
      mov cx, 0
      mov dx, 10001b      { Open if exists, create of not.  }
      lds si, fname
      mov di, 0
      int $21
      jc @1               { error creating file }
      mov bx, ax          { ok, close it again  }
      mov ah, $3E
      int $21
      jc @1               { error closing file }
      mov ax, 0           { ok, return zero    }
    @1:
      pop ds
      mov [DosError],ax
    end;                { LCreateEmpty }

    { Pascal-string based interface routines }

    function LFNFindFirst(filespec: string; attr: word; var S: TLFNSearchRec): word;
    { Implement the FindFirst procedure. This routine will call the TP }
    { FindFirst if LFN is not supported, and will translate the result }
    { into the TLFNSearchRec variable.                                 }
    { NOTE: Under Win95, the filespec will be checked against both the }
    { long and the short filenames, so an additional check may be      }
    { necessary.                                                       }
    begin
      If LFNAble then
      begin
        filespec := filespec + #0;
        LFindFirst(PChar(@Filespec[1]),Attr,S);
        if (DosError=0) and (S.shortname[0]=#0) then
        begin
          move(S.name,S.shortname,sizeof(S.shortname)-1);
          S.shortname[sizeof(S.shortname)-1]:=#0;
        end;
      end else
      begin
        FillChar(S,sizeof(S),0);
    {$IFDEF WINDOWS}
        FileSpec:=FileSpec+#0;
        FindFirst(PChar(@FileSpec[1]),Attr,PLFNShortSearchRec(@S)^.SRec);
    {$ELSE}
        FindFirst(FileSpec,Attr,PLFNShortSearchRec(@S)^.SRec);
    {$ENDIF}
        if DosError=0 then
        begin
    {$IFDEF WINDOWS}
          Move(PLFNShortSearchRec(@S)^.SRec.name,S.Name,13); S.name[13]:=#0;
    {$ELSE}
         FillChar(S.Name,14,0);
         Move(PLFNShortSearchRec(@S)^.SRec.name[1],S.Name,
              byte(PLFNShortSearchRec(@S)^.SRec.name[0]));
    {$ENDIF}
          DosTimeToLFN(PLFNShortSearchRec(@S)^.SRec.Time,S.LastMod);
          S.Attr:=PLFNShortSearchRec(@S)^.SRec.Attr;
          S.Size:=PLFNShortSearchRec(@S)^.SRec.Size;
        end;
      end;
      LFNFindFirst:=DosError;
    end;     { LFNFindFirst }

    function LFNFindNext(var S: TLFNSearchRec): word;
    { Implement the FindNext procedure. This routine will call the TP  }
    { FindNext if LFN is not supported, and will translate the result  }
    { into the TLFNSearchRec variable.                                 }
    { NOTE: Under Win95, the filespec will be checked against both the }
    { long and the short filenames, so an additional check may be      }
    { necessary.                                                       }
    begin
      If LFNAble then
      begin
        LFindNext(S);
        if (DosError=0) and (S.shortname[0]=#0) then
        begin
          move(S.name,S.shortname,sizeof(S.shortname)-1);
          S.shortname[sizeof(S.shortname)-1]:=#0;
        end;
      end else
      begin
        FindNext(PLFNShortSearchRec(@S)^.SRec);
        if DosError=0 then
        begin
    {$IFDEF WINDOWS}
          Move(PLFNShortSearchRec(@S)^.SRec.name,S.Name,13); S.name[13]:=#0;
    {$ELSE}
          FillChar(S.Name,14,0);
          Move(PLFNShortSearchRec(@S)^.SRec.name[1],S.Name,
               byte(PLFNShortSearchRec(@S)^.SRec.name[0]));
    {$ENDIF}
          DosTimeToLFN(PLFNShortSearchRec(@S)^.SRec.Time,S.LastMod);
          S.Attr:=PLFNShortSearchRec(@S)^.SRec.Attr;
          S.Size:=PLFNShortSearchRec(@S)^.SRec.Size;
        end;
      end;
      LFNFindNext:=DosError;
    end;   { LFNFindNext }

    function LFNFindClose(var S: TLFNSearchRec): word;
    { Close the Win95 TLFNSearchRec structure. if LFN is not suppported, }
    { this routine does nothing.                                         }
    begin
      If LFNAble then LFNFindClose:=LFindClose(S)
      else LFNFindClose:=0;
    end;  {function}

    function LFNShortName(LongName: string): ShortPathStr;
    { Returns the short name of the specified file. If LFN is not }
    { supported, returns the input filename.                      }
    var
      P,Q: PChar;
      i,len: integer;
    begin
      if not LFNAble then
      begin
        LFNShortName:=LongName; Exit;
      end;
      len:=length(LongName);
      for i:=1 to len do LongName[i-1]:=LongName[i]; LongName[len]:=#0;
      P:=@Longname;
      GetMem(Q,270); Q^:=#0;
      if LGetShortName(P,Q)=0 then
      begin
        if Q^=#0 then LFNShortName:=LongName
        else LFNShortName:=StrPas(Q);
      end else LFNShortName:='';
      FreeMem(Q,270);
    end;                     { ShortName }

    function LFNLongName(ShortName: ShortPathStr): string;
    { Returns the long name of the specified file. If LFN is not }
    { supported, returns the input filename.                     }
    var
      SRec: PLFNSearchRec;
      P: PChar;
      P0,D,N,E: PString;
      i,len: integer;
    begin
      LFNLongName:=ShortName; if not LFNAble then Exit;
      len:=length(ShortName); if len=0 then Exit;
      New(D); LFNFSplit(ShortName,D,Nil,Nil);
      for i:=1 to len do ShortName[i-1]:=ShortName[i]; ShortName[len]:=#0;
      GetMem(P0,270); P:=@PByteArray(P0)^[1]; P0^:=''; P^:=#0;
      LGetLongName(PChar(@ShortName),P); PByteArray(P)^[256]:=#0;
      P0^[0]:=Chr(StrLen(P));
      Dispose(D);
      if P^=#0 then LFNLongName:=ShortName
      else LFNLongName:=StrPas(P);
      FreeMem(P0,270);
    end;               { LFNLongName }

    {====================================================================}
    { DERIVATIVE SERVICE ROUTINES.                                       }
    { This is a set of routines which mimic, as closely as possible, the }
    { equivalent routines in Turbo Pascal, except that they support      }
    { long filenames. In many cases, they are drop-in replacements, but  }
    { some are new.                                                      }
    {====================================================================}

    procedure LFNUnpackTime(var LTime: comp; var DT: TDateTime);
    { Convert 64-bit time to date/time record }
    begin
      UnpackTime(LFNTimeToDos(LTime),DT);
    end;

    function LFNGetFAttr(var F; var Attr: word): integer;
    { Get the attributes of a file, using its File variable. }
    { The file should have been LFNAssign'ed first. Its not  }
    { strictly required, except for error checking.          }
    { Returns the DOS error code.                            }
    begin
      LFNGetFAttr:=0; DosError:=0;
      with PLFNFileParam(@F)^ do
        if (Magic<>LFNMagic) or (not Initialized) then
        begin
          DosError:=2; LFNGetFAttr:=2; Exit;
        end;
      GetFAttr(F,Attr); LFNGetFAttr:=DosError;
    end;               { LFNGetFAttr }

    function LFNFileExist(fname: string): boolean;
    { Returns TRUE if the file exists, and FALSE otherwise. }
    var
      fl: file;
      attr,i,len: word;
      P: PChar;
    begin
      if fName='' then
      begin
        LFNFileExist:=false; Exit;
      end;
      if LFNAble then
      begin
        len:=length(fname); for i:=1 to len do fname[i-1]:=fname[i];
        fname[len]:=#0; LGetAttr(PChar(@fname),Attr)
      end else
      begin
        Assign(fl,fname); GetFAttr(fl,Attr);
      end;
      LFNFileExist:=(DosError=0);
    end;                    { LFNFileExist }

    function LFNFSearch(Path,DirList: string): string;
    { Search for a file in a semicolon-delimited list of directories. }
    { This is a drop-in replacement for FSearch (TP6), which I        }
    { personally find more useful than the later FileSearch.          }
    var
      i,len,Ind: integer;
      which: PChar;
      tmp: PString;
      found: boolean;
    begin
      LFNFSearch:=''; if Path='' then Exit;
      if LFNAble then
      begin
        if (DirList='') and not LFNFileExist(Path) then Exit;
        if DirList='' then
        begin
          LFNFSearch:=Path; Exit;
        end;
        Ind:=1; New(tmp); found:=false;
        while (DirList<>'') and (DirList[1]=';') do delete(DirList,1,1);
        repeat
          tmp^:='';
          while (Ind<=length(DirList)) and (DirList[Ind]<>';') do
          begin
            tmp^:=tmp^+DirList[Ind]; inc(Ind);
          end;
          while (Ind<=length(DirList)) and (DirList[Ind]=';') do inc(Ind);
          if Ind>length(DirList) then Ind:=0 else inc(Ind);
          if tmp^<>'' then
          begin
            if tmp^[length(tmp^)]<>'\' then tmp^:=tmp^+'\';
            if LFNFileExist(tmp^+Path) then
            begin
              LFNFSearch:=LFNFExpand(tmp^+Path); found:=true;
            end;
          end;
        until found or (Ind=0);
        Dispose(tmp);
      end else
      begin
    {$IFDEF WINDOWS}
        GetMem(Which,256);
        len:=length(Path); for i:=1 to len do Path[i-1]:=Path[i]; Path[len]:=#0;
        len:=length(DirList); for i:=1 to len do DirList[i-1]:=DirList[i]; DirList[len]:=#0;
        FileSearch(which,PChar(@Path),PChar(@DirList));
        LFNFSearch:=StrPas(Which); FreeMem(Which,256);
    {$ELSE}
        LFNFSearch:=FSearch(Path,DirList);
    {$ENDIF}
      end;
    end;                     { LFNFSearch }

    procedure LFNFSplit(Path: string; Dir,Name,Ext: PString);
    { An almost drop-in replacement for the TP6 FSplit, which supports LFN.   }
    { The additional difference is that the arguments are passed as pointers, }
    { rather than VAR variables. This is so that if a file segment is not     }
    { needed, one can pass NIL in the respective variable, and it will not    }
    { be returned.                                                            }
    var
      StrPt,StrSlash,StrEnd: integer;
    begin
      StrEnd:=length(Path);
      StrPt:=StrEnd; StrSlash:=0;
      while(StrPt>0) and (Path[StrPt]<>'.') and (Path[StrPt]<>'\') do dec(StrPt);
      if (StrPt>0) and (Path[StrPt]='.') then  { found extension }
      begin
        StrSlash:=StrPt-1;
        while (StrSlash>0) and (Path[StrSlash]<>'\') do dec(StrSlash);
      end else if (StrPt>0) and (Path[StrPt]='\') then  { No extension }
      begin
        StrSlash:=StrPt; StrPt:=StrEnd+1;
      end else if StrPt=0 then   { All name }
      begin
        StrPt:=StrEnd+1; StrSlash:=0;
      end;

      if Dir<>Nil then
      begin
        Dir^:='';
        if StrSlash>0 then Dir^:=Copy(Path,1,StrSlash);
      end;
      if Name<>Nil then
      begin
        Name^:='';
        if StrPt>StrSlash+1 then Name^:=Copy(Path,StrSlash+1,StrPt-StrSlash-1);
      end;
      if Ext<>Nil then
      begin
        Ext^:='';
        if StrPt<=StrEnd then Ext^:=Copy(Path,StrPt,255);
      end;
    end;                   { LFNFSplit }

    function LFNFExpand(Path: string): string;
    { Drop-in replacement for the TP6 FExpand, which supports LFN. }
    { Personally, I prefer it to the later FileExpand.             }
    var
      D,N,E,P: PString;
      i,j,ndots: integer;
    begin
      for i:=1 to length(Path) do if Path[i]='/' then Path[i]:='\';
      LFNFExpand:='';
      GetMem(P,270);
    {$IFDEF WINDOWS}
      FileExpand(PChar(P)+1,'.'); P^[0]:=chr(StrLen(PChar(P)+1));
    {$ELSE}
      P^:=FExpand('.');
    {$ENDIF}
      if (P^<>'') and (P^[length(P^)]<>'\') then P^:=P^+'\';
      P^:=LFNLongName(P^);
      ndots:=0;
      while (ndots<length(Path)) and (Path[Ndots+1]='.') do inc(ndots);
      if (length(Path)>1) and (UpCase(Path[1]) in ['A'..'Z']) and (Path[2]=':') then
        P^:=Path         { Fully qualified }
      else if Path[1]='\' then        { Only drive missing }
        P^:=Copy(P^,1,2)+Path
      else begin
        for i:=1 to ndots-1 do    { relative filenames, multiple dots }
        begin
          if length(P^)>3 then
          begin
            j:=length(P^)-1;
            while (j>3) and (P^[j]<>'\') do dec(j);
            P^[0]:=Chr(j);
          end;
          delete(Path,1,1);
        end;
        if Pos('.\',Path)=1 then Delete(Path,1,2)
        else if Pos('.',Path)=1 then Delete(Path,1,1);
        P^:=P^+Path;
      end;
      LFNFExpand:=P^;
      FreeMem(P,270);
    end;                     { LFNFExpand }

    procedure CanonicalFname(var S: string);
    { This routine takes a filename and changes its case to a canonical form: }
    { 1. Without LFN support, lowercase.                                      }
    { 1. For existing short filenames, or dir names, lowercase.               }
    { 2. For existing long filenames, the system-supplied case.               }
    { 3. For non-existing filenames, expand the existing part of the path,    }
    {    and leave the rest unchanged.                                        }
    { In all cases '/' is changed to '\'.                                     }
    type
      TBf = array[1..3] of string;
    var
      lname,sname,res: Pstring;
      Buf: ^TBf;
      i,j: integer;
      exists: boolean;

    procedure StrLwr(var L: string);
    var
      i: integer;
    begin
      for i:=1 to length(L) do if L[i] in ['A'..'Z'] then
        L[i]:=Chr(Ord(L[i])-Ord('A')+Ord('a'));
    end;

    begin
      for i:=1 to length(S) do if S[i]='/' then S[i]:='\';
      if LFNAble then
      begin
        New(Buf);
        Buf^[1]:='';
        repeat
          i:=Pos('\',S); if i=0 then i:=length(S);
          if S[i]='\' then exists:=LFNFileExist(Buf^[1]+Copy(S,1,i)+'.')
          else exists:=LFNFileExist(Buf^[1]+Copy(S,1,i));
          if exists then
          begin
            Buf^[2]:=LFNShortName(Buf^[1]+Copy(S,1,i));
            Buf^[3]:=LFNLongName(Buf^[2]);
            j:=length(Buf^[2])-1; while (j>0) and (Buf^[2][j]<>'\') do dec(j);
            Delete(Buf^[2],1,j);
            j:=length(Buf^[3])-1; while (j>0) and (Buf^[3][j]<>'\') do dec(j);
            Delete(Buf^[3],1,j);
            if Buf^[3]=Buf^[2] then StrLwr(Buf^[3]);
            Buf^[1]:=Buf^[1]+Buf^[3];
            delete(S,1,i);
          end;
        until (not exists) or (S='');
        S:=Buf^[1]+S;
        Dispose(Buf);
      end else StrLwr(S);
    end;                { CanonicalFname }

    function CanonicalFilename(fname: PChar): PChar;
    begin
      CanonicalFName(PChar2PString(fname)^);
      fname:=PString2PChar(PString(fname));
      CanonicalFilename:=fname;
    end;

    {=========================================================================}
    { BINARY AND TEXT FILE INPUT/OUTPUT ROUTINES.                             }
    { This set of routines is an interface between the LFN API and the Pascal }
    { style input/output routines. It uses ordinary text and file variables,  }
    { storing special info in the UserData field. The variable is then fully  }
    { compatible with the Pascal read(ln), write(ln), BlockRead, BlockWrite,  }
    { etc input/output routines.                                              }
    { All the functions return the DOS error code, and also put it into       }
    { DOSERROR. The global "LFNRuntimeError" determines if runtime errors     }
    { will be generated (by default, no.)                                     }
    {=========================================================================}

    procedure LFNNew(var F; IsText: boolean);
    { This routine prepares a text or file variable for LFN use. It allocates }
    { memory for the long name, and initializes the entries in the UserData.  }
    { It must be called before any other.                                     }
    { The "IsText" flag tells if the variable is of type "file" or "text".    }
    begin
      with PLFNFileParam(@F)^ do
      begin
        TextFile:=IsText;
        Initialized:=false;
        Magic:=LFNMagic;
        lfname:=Nil; plfname:=Nil;
        if LFNAble then
        begin
          GetMem(lfname,270); FillChar(lfname^,270,0);
          plfname:=PChar(@PByteArray(lfname)^[1]);
        end;
      end;
    end;                    { LFNNew }

    function LFNAssign(var F; name: string): integer;
    { This routine replaces the Pascal "Assign" routine. For existing files, }
    { it first determines the short name, and then invokes "Assign". If the  }
    { file does not exist, it only stores the information in the UserData    }
    { fields, since the equivalent short name is not known. The assign       }
    { operation is then deferred to the first "LFNRewrite" call.             }
    { LFNAssign may be called for the same variable for different filenames, }
    { so long as the type (file or text) is the same.                        }
    var
      tmp,fname: PString;
      IsText: boolean;
      P: PChar;
    begin
      if PLFNFileParam(@F)^.Magic<>LFNMagic then
      begin
        DosError:=LFNErr_NotAllocated;
        LFNAssign:=DosError;
    {$IFDEF WINDOWS}
        MessageBox(0,'Bug, LFNAssign',Nil,mb_ok);    { for debugging }
    {$ENDIF}
        Exit;
      end;
      LFNAssign:=0; DosError:=0;
      if LFNAble then
      begin
        GetMem(fname,270);
        if LFNFileExist(name) then
        begin
          fname^:=LFNShortName(name);
          PByteArray(fname)^[length(fname^)+1]:=#0;
        end else fname^:='';
      end else fname:=@name;
      with PLFNFileParam(@F)^ do
      begin
        if fname^='' then Initialized:=false
        else begin
          IsText:=TextFile; tmp:=lfname; P:=plfname;
          if IsText then Assign(text(F),fname^) else assign(file(F),fname^);
          Initialized:=true;
          TextFile:=IsText; lfname:=tmp; plfname:=P;
          Magic:=LFNMagic;
        end;
        if LFNAble then
        begin
          lfname^:=name;
          PByteArray(lfname)^[length(lfname^)+1]:=#0;
        end;
      end;
      if LFNAble then FreeMem(fname,270);
    end;                       { LFNAssign }

    function LFNRewrite(var F; RecLen: word): integer;
    { This routine readies a file for output. If the file does not yet exist, }
    { it creates an empty file to get the system-determined short name, and   }
    { performs a deferred Assign, since at Assign time a short name was not   }
    { yet available (see description of LFNAssign).                           }
    { The routine returns 0 if successful, and the DOS errorcode if not.      }
    var
      tmp,fname: PString;
      IsText: boolean;
      P: PChar;

    function Err(e: byte): byte;
    begin
      LFNRewrite:=e; DosError:=e; Err:=e;
      if LFNRuntimeErrors and (e<>0) then RunError(e);
    end;

    begin
      Err(0);
      if PLFNFileParam(@F)^.Magic<>LFNMagic then
      begin
    {$IFDEF WINDOWS}
        MessageBox(0,'Bug, LFNRewrite',Nil,mb_ok);   { for debugging }
    {$ENDIF}
        Err(LFNErr_NotAllocated); Exit;
      end;
      if LFNAble then
      with PLFNFileParam(@F)^ do
      begin
        if not Initialized then    { create the file, so we can get a valid short name }
        begin
          if Err(LCreateEmpty(plfname))=0 then
          begin
            New(fname);
            fname^:=LFNShortName(lfname^);
            IsText:=TextFile; tmp:=lfname; P:=plfname;
            if IsText then Assign(text(F),fname^) else assign(file(F),fname^);
            Initialized:=true;
            TextFile:=IsText; lfname:=tmp; plfname:=P;
            Magic:=LFNMagic;
          end;
        end;
        if Initialized then
        begin
          {$I-}
          if TextFile then Rewrite(text(F))
          else if RecLen=0 then Rewrite(file(F))
          else Rewrite(file(F),RecLen);
          Err(IoResult);
          {$I+}
        end;
      end else with PLFNFileParam(@F)^ do
      if Initialized then
      begin
        {$I-}
        if TextFile then Rewrite(text(F))
        else if RecLen=0 then rewrite(file(F))
        else Rewrite(file(F),RecLen);
        Err(IoResult);
        {$I+}
      end;
    end;               { LFNRewrite }

    function LFNAppend(var F; RecLen: word): integer;
    { This routines opens a previously LFNAssigned for output at the EOF. }
    { Its not really necessary, except that it performs additional error  }
    { checking to make  sure that the file was properly initialized.      }
    { Also, in contrast to the TP Append, if the file does not exist the  }
    { routine calls LFNRewrite to create and open it.                     }
    { The routine returns 0 if successful, and the DOS errorcode if not.  }

    function Err(e: byte): byte;
    begin
      LFNAppend:=e; DosError:=e; Err:=e;
      if LFNRuntimeErrors and (e<>0) then RunError(e);
    end;

    begin
      Err(0);
      if PLFNFileParam(@F)^.Magic<>LFNMagic then
      begin
        Err(LFNErr_NotAllocated); Exit;
      end;
      with PLFNFileParam(@F)^ do
      begin
        if Magic<>LFNMagic then
        begin
          Err(LFNErr_NotAllocated); Exit;
        end else if not TextFile then
        begin
          Err(LFNErr_NotATextFile); Exit;
        end else if not Initialized then Err(LFNRewrite(F,RecLen))
        else begin
          {$I-}
          Append(text(F)); Err(IoResult);
          {$I+}
        end;
      end;
    end;             { LFNAppend }

    function LFNReset(var F; RecLen: word): integer;
    { This routines opens a file for input, instead of "reset". Its not really }
    { necessary, except that it performs additional error checking to make     }
    { sure that the file was properly initialized.                             }
    { The routine returns 0 if successful, and the DOS errorcode if not.       }

    procedure Err(e: byte);
    begin
      LFNReset:=e; DosError:=e;
      if LFNRuntimeErrors and (e<>0) then RunError(e);
    end;

    begin
      Err(0);
      if PLFNFileParam(@F)^.Magic<>LFNMagic then
      begin
    {$IFDEF WINDOWS}
        MessageBox(0,'Bug, LFNReset',Nil,mb_ok);   { for debugging }
    {$ENDIF}
        Err(LFNErr_NotAllocated); Exit;
      end;
      with PLFNFileParam(@F)^ do
      begin
        if not Initialized then LFNReset:=LFNErr_UnInitialized
        else begin
          {$I-}
          if TextFile then Reset(text(F))
          else if RecLen=0 then Reset(file(F))
          else Reset(file(F),RecLen);
          Err(IoResult);
          {$I+}
        end;
      end;
    end;             { LFNReset }

    function LFNErase(var F): integer;
    { This routines erases a previously LFNAssigned, but not opened, file. }
    { Its not really necessary, except that it performs additional error   }
    { checking to make  sure that the file was properly initialized. Also, }
    { it re-assignes the file so it will be properly ready for a rewrite.  }
    { The routine returns 0 if successful, and the DOS errorcode if not.   }
    var
      S: PString;
      S1: PChar;

    function Err(e: byte): byte;
    begin
      LFNErase:=e; DosError:=e; Err:=e;
      if LFNRuntimeErrors and (e<>0) then RunError(e);
    end;

    begin
      with PLFNFileParam(@F)^ do
      begin
        LFNErase:=0;
        if (Magic<>LFNMagic) then
        begin
          Err(LFNErr_NotAllocated); Exit;
        end else if (not Initialized) then
        begin
          Err(LFNErr_UnInitialized); Exit;
        end;
        LFNClose(F);
        if not LFNAble then
        begin
          GetMem(S,81); S1:=PChar(@PByteArray(S)^[1]);
          Move(SName,S1^,80); S^:=Chr(StrLen(S1));
        end;
        {$I-}
        if TextFile then Erase(text(F)) else Erase(file(F));
        if Err(IoResult)=0 then
        begin
          if LFNAble then LFNAssign(F,lfname^)
          else begin
            LFNAssign(F,S^); FreeMem(S,81);
          end;
        end;
        {$I+}
      end;
    end;                   { LFNErase }

    function LFNClose(var F): integer;
    { This routines closes a previously LFNAssigned and opened file.     }
    { Its not really necessary, except that it performs additional error }
    { checking to make  sure that the file was properly initialized.     }
    { The routine returns 0 if successful, and the DOS errorcode if not. }

    function Err(e: byte): byte;
    begin
      LFNClose:=e; DosError:=e; Err:=e;
      if LFNRuntimeErrors and (e<>0) then RunError(e);
    end;

    begin
      Err(0);
      with PLFNFileParam(@F)^ do
      begin
        if Magic<>LFNMagic then
        begin
          Err(LFNErr_NotAllocated); Exit;
        end else if not Initialized then
        begin
          Err(LFNErr_UnInitialized); Exit;
        end;
        {$I-}
        if TextFile then close(text(F)) else close(file(F));
        Err(IoResult);
        {$I+}
      end;
    end;                   { LFNClose }

    procedure LFNDispose(var F);
    { This routine disposes of the additional memory allocated by LFNNew, }
    { and cleans up the UserData fields. If the file is open, it also     }
    { closes it, so that there is no need to call LFNClose previously.    }
    begin
      with PLFNFileParam(@F)^ do
      begin
        if (Magic<>LFNMagic) or (not Initialized) then Exit;
        LFNClose(F);
        if lfname<>Nil then FreeMem(lfname,270);
        lfname:=Nil; plfname:=Nil; Initialized:=false; Magic:='';
      end;
    end;                 { LFNDispose }

    function LFNRename(var F; NewName: string): integer;
    { This routines renames a previously LFNAssigned, but not opened, file. }
    { The file variable is then re-assigned to the new name.                }
    { The routine returns 0 if successful, and the DOS errorcode if not.    }
    var
      i,len: integer;

    function Err(e: byte): byte;
    begin
      LFNRename:=e; DosError:=e; Err:=e;
      if LFNRuntimeErrors and (e<>0) then RunError(e);
    end;

    begin
      Err(0);
      if NewName='' then Exit;
      with PLFNFileParam(@F)^ do
      begin
        if Magic<>LFNMagic then
        begin
          Err(LFNErr_NotAllocated); Exit;
        end else if not Initialized then
        begin
          Err(LFNErr_UnInitialized); Exit;
        end;
        if not LFNAble then   { The usual TP stuff }
        begin
          {$I-}
          if TextFile then Rename(text(F),NewName) else Rename(file(F),NewName);
          Err(IoResult);
          {$I+}
        end else                       { LFN }
        begin
          len:=length(NewName);
          for i:=1 to len do NewName[i-1]:=NewName[i]; NewName[len]:=#0;
          if Err(LRenameFile(plfname,PChar(@NewName)))=0 then
          begin
            for i:=len downto 1 do
              NewName[i]:=NewName[i-1]; NewName[0]:=chr(len);
            LFNAssign(F,NewName);
          end;
        end;
      end;
    end;                    { LFNRename }

    begin
      LFNAble:=SupportsLFN;
    end.

[Back to FILES SWAG index] [Back to Main SWAG index] [Original]