fnames.pas

Turbo Pascal 6.0编译器源码

unit FNames;

{$O+,F+,S-}

interface

uses TDos;

procedure ConvertPath(var Path: PathStr; MaxLen: Integer);
procedure ShortenPath(var Path: PathStr; MaxLen: Integer);

implementation

function Begins(A, B: string): Boolean; near; assembler;
asm
        PUSH    DS
        XOR     AX,AX
        LES     DI,B
        LDS     SI,A
        LODSB
        XCHG    AX,CX
        INC     DI
        CLD
        REPE    CMPSB
        MOV     AX,0
        JNE     @@1
        INC     AX
@@1:    POP     DS
end;

procedure ShortenDir(var Dir: DirStr);
var
  Root: Boolean;
  I: Integer;
begin
  if Dir = '\' then
    Dir := ''
  else
  begin
    if Dir[1] = '\' then
    begin
      Root := True;
      Dir := Copy(Dir, 2, 255);
    end else
      Root := False;
    if Dir[1] = '.' then
      Dir := Copy(Dir, 5, 255);
    I := Pos('\', Dir);
    if I <> 0 then
      Dir := '...\' + Copy(Dir, I + 1, 255)
    else
      Dir := '';
    if Root then
      Dir := '\' + Dir;
  end;
end;

procedure ConvertPath(var Path: PathStr; MaxLen: Integer);
var
  Drive: string[3];
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
  CurDir: DirStr;
begin
  if Path = '' then
    Exit;
  FSplit(Path, Dir, Name, Ext);
  Drive := '';
  if (Length(Dir) > 2) and (Dir[2] = ':') then
  begin
    if (Dir[1] = 'A') or (Dir[1] = 'B') then
      Dir := ''
    else
    begin
      CurDir := GetCurDir(UpCase(Path[1]));
      if Length(CurDir) > 3 then
        CurDir := CurDir + '\';
      Dir := Copy(Dir, 3, 255);
      CurDir := Copy(CurDir, 3, 255);
      if Begins(CurDir, Dir) then
        Dir := Copy(Dir, Length(CurDir) + 1, 255);
    end;
    if GetCurDrive <> Path[1] then
      Drive := Path[1] + ':';
  end;
  Path:=Drive + Dir + Name + Ext;
  ShortenPath(Path, MaxLen);
end;

procedure ShortenPath(var Path: PathStr; MaxLen: Integer);
var
  Drive: string[3];
  Dir: DirStr;
  Name: NameStr;
  Ext: ExtStr;
begin
  FSplit(Path, Dir, Name, Ext);
  if Dir[2] = ':' then
  begin
    Drive := Copy(Dir, 1, 2);
    Dir := Copy(Dir, 3, 255);
  end else
    Drive := '';
  while (Length(Path) > MaxLen) and
    ((Length(Dir) <> 0) or (Length(Drive) <> 0)) do
  begin
    if Dir = '\...\' then
    begin
      Drive := '';
      Dir := '...\';
    end else
      if Dir = '' then
        Drive := ''
      else
        ShortenDir(Dir);
    Path := Drive + Dir + Name + Ext;
  end;
end;

end.