getwrd.pas

Source code Delphi FTP-server

{$A+,B-,C+,D+,E-,F-,G+,H-,I-,J+,K-,L+,M-,N+,O-,P+,Q-,R-,S-,T-,U-,V+,W-,X+,Y+,Z1}
unit getwrd;

{--------------------------------------------------------------------}
{ GetWrd module. Service functions.                                  }
{ 11/15/1999 Drt.                                                    }
{--------------------------------------------------------------------}

interface

uses
 SysUtils;

function getword(s : string; n : byte) : string;
function getend(s : string; n : byte) : string;
function AllTrim(s : string) : string;
function stupcase(s : string) : string;
function Space(n : integer) : string;
function NormalizePath(Path : string) : string;
function AddSlash(s : string) : string;
function IsName8_3(s : string) : boolean;
function BitPath(var Path,OutS : string) : boolean;
function UpDir(Path : string) : string;
function DownDir(Path,Add : string) : string;

implementation

function UpDir(Path : string) : string;
begin
if (Path <> '') and (Path[length(Path)] = '/') then
  setlength(path,length(Path)-1);
while (Path <> '') and (Path[length(Path)] <> '/') do
  setlength(path,length(Path)-1);
if (Path <> '') and (Path <> '/') and (Path[length(Path)] = '/') then
  setlength(path,length(Path)-1);
result:=Path;
end;

function DownDir(Path,Add : string) : string;
begin
if (Path <> '') and (Path[length(Path)] <> '/') then
  Path:=Path+'/';
result:=Path+trim(Add);
end;

function BitPath(var Path,OutS : string) : boolean;
begin
result:=false;
if Path = '' then exit;
OutS:='';
while (Path <> '') and (Path[1] <> '/') do
  begin
  OutS:=OutS+Path[1];
  Path:=copy(Path,2,255);
  end;
if Path[1] = '/' then
  Path:=copy(Path,2,255);
result:=true;
end;

function IsName8_3(s : string) : boolean;
var
 s1 : string[20];
 i  : integer;
begin
result:=false;
i:=pos('.',s);
if i = 0 then exit;
s1:=copy(s,i+1,255);
setlength(s,i-1);
if (length(s) > 8) or (length(s1) > 3) then exit;
result:=true;
end;

function AddSlash(s : string) : string;
 begin
 if length(s) <> 2 then
   begin
   if not (s[length(s)] in ['\','/']) then
     s:=s+'\';
   end
 else
   if s[2] <> ':' then
     s:=s+'\';
 AddSlash:=s;
 end;

function NormalizePath(Path : string) : string;
var
 i : integer;
 s,s1 : string;
begin
Path:=trim(Path);
if (length(Path) > 1) and (Path[2] = ':') then
  Path:=copy(Path,3,255);
for i:=1 to length(Path) do
  if Path[i] = '\' then Path[i]:='/';
s1:='/';
while BitPath(Path,s) do
  begin
  if s <> '.' then
    begin
    if s = '..' then
      s1:=UpDir(s1)
    else
      s1:=DownDir(s1,s);
    end;
  end;
result:=s1;
end;

function Space(n : integer) : string;
var
 s : string;
begin
s:='';
while n > 0 do
  begin
  s:=s+' ';
  dec(n);
  end;
Space:=s;
end;

function stupcase(s : string) : string;
var
 i : byte;
begin
for i:=1 to length(s) do
  s[i]:=upcase(s[i]);
stupcase:=s;
end;

function AllTrim(s : string) : string;
begin
while (s[1] in [' ',#0]) and (length(s) <> 0) do
  s:=copy(s,2,250);
while (length(s) <> 0) and (s[length(s)] in [' ',#0]) do
  setlength(s,length(s)-1);
alltrim:=s;
end;

function getword(s : string; n : byte) : string;
 var
  i : byte;
 begin
 getword:='';
 s:=alltrim(s);
 for i:=2 to n do
   if pos(' ',s) > 0 then
     s:=alltrim(copy(s,pos(' ',s),255))
   else
     s:='';
 if s <> '' then
   begin
   if pos(' ',s) > 0 then
     getword:=alltrim(copy(s,1,pos(' ',s)))
   else
     getword:=s;
   end;
 end;

function getend(s : string; n : byte) : string;
 var
  i : byte;
 begin
 getend:='';
 s:=alltrim(s);
 for i:=2 to n do
   if pos(' ',s) > 0 then
     s:=alltrim(copy(s,pos(' ',s),255))
   else
     s:='';
 getend:=s;
 end;

end.