{-------------------------------------------------------------------------------
Author:      Jan Krieger, Ismaning (Munich), Germany
             jan@jkrieger.de
             http://www.jkrieger.de/
Date:        November 17. 2000
Name:        unit JKTools;
Version:     1.0
Copyright:   (c) 2000 by Jan W. Krieger. All rights reserved.
Description: unit with a collection of tool procedures
             description of the procedure: see sourcecode
Status:      This unit is FREEWARE, so no support can be granted
             Everybody may feel free to copy and use it.
             If you alter the sourcecode, it would be kind to send me the
             new source!

--------------------------------------------------------------------------------
                   This comment may not be deleted !!!
--------------------------------------------------------------------------------}

unit jkTools;
//verschiedene Routinen

interface

uses classes, comctrls, windows, sysutils, shellAPI, dialogs, zlib;

type
  tjkchars = set of char;

// copied from RX Library
function DelBSpace(const S: string): string;
function DelESpace(const S: string): string;
function DelRSpace(const S: string): string;
function HextoDec(const S: string): Longint;

// own Procedure/Functions
function ReadString(s:TStream):ansistring;
procedure WriteString(s:TStream; str:ansistring);
procedure InsertTextFile(var f:system.text; filename:string);
function FTPExtractFileName(fn:string):string;
function filegetsize(fn:string):longint;
function GetTreePath(node:TTreeNode;divider:string):string;
function FTPGetReturn(dir:string):string;
function GetTempFileName:string;
procedure ExtractLinkedFiles(projPath, filename:string; sl:TStringList);
function StringConsistsOf(text:string; chars: tjkchars):boolean;
function boolToStr(value:boolean):string;
procedure JKShowFile(F:string);
procedure JKShowWWW(handle:THandle;url:string);
procedure ExpandStream(inStream, outStream :TStream); overload;
procedure ExpandStream(inStream, outStream :TStream; const BufferSize:longint); overload;
procedure PackStream(inStream, outStream :TStream; CompressionLevel:TCompressionLevel);
function jkEncodeXOR(key, data:string):string;
function jkDecodeXOR(key, data:string):string;
function NumberOfLines(text: string): longint;
function getFileDate(fn:string):TDateTime;
function hasSubdirectories(directory:string):boolean;
procedure ShowErrorMessage(text: string);
function ShortenPrename(name: string): string;

implementation

//FILE: gibt true zurück, wenn directory Unterverzeichnisse enthält
function hasSubdirectories(directory:string):boolean;
var s:TSearchrec;
begin
  result:=false;
  if findfirst(IncludeTrailingBackslash(directory)+'*.*', faAnyFile, s)=0 then begin
    repeat
      if (s.Attr and faDirectory)=faDirectory then result:=true;
    until (findnext(s)<>0) or (result=true);
  end;
  findclose(s);
end;

function jkEncodeXOR(key, data:string):string;
var j,i:longint;
begin
  result:='';
  j:=1;
  for i:=1 to length(data) do begin
    result:=result+chr(ord(data[i])xor ord(key[j]));
    inc(j);
    if j>length(key) then j:=1;
  end;
end;

function jkDecodeXOR(key, data:string):string;
var j,i:longint;
begin
  result:='';
  j:=1;
  for i:=1 to length(data) do begin
    result:=result+chr(ord(data[i])xor ord(key[j]));
    inc(j);
    if j>length(key) then j:=1;
  end;
end;

// Packe einen Stream mittels ZLIB
procedure PackStream(inStream, outStream :TStream; CompressionLevel:TCompressionLevel);
var ZStream: TCompressionStream;
begin
    ZStream := TCompressionStream.Create(CompressionLevel, OutStream);
  try
    ZStream.CopyFrom(InStream, 0);
  finally
    ZStream.Free;
  end;
end;

// Entpacke einen Stream mittels ZLIB
procedure ExpandStream(inStream, outStream :TStream);
const
  BufferSize = 4096;
var
  Count: Integer;
  ZStream: TDecompressionStream;
  Buffer: array[0..BufferSize-1] of Byte;
begin
  ZStream := TDecompressionStream.Create(InStream);
  try
    while True do
      begin
        Count := ZStream.Read(Buffer, BufferSize);
        if Count <> 0 then OutStream.WriteBuffer(Buffer, Count) else Break;
      end;
  finally
    ZStream.Free;
  end;
end;

procedure ExpandStream(inStream, outStream :TStream; const BufferSize:longint);
var
  Count: Integer;
  ZStream: TDecompressionStream;
  Buffer: array of Byte;
begin
  SetLength(Buffer, BufferSize);
  ZStream := TDecompressionStream.Create(InStream);
  try
    while True do
      begin
        Count := ZStream.Read(Buffer, BufferSize);
        if Count <> 0 then OutStream.WriteBuffer(Buffer, Count) else Break;
      end;
  finally
    ZStream.Free;
  end;
  //outStream.Position:=0;
end;

//Zeige eine WWW-Datei im STandard-Browser
procedure JKShowWWW(handle:THandle;url:string);
var s:string;
begin
  s:='http://'+url;
  if (pos('http://',ansilowercase(url))<>0)or(pos('ftp://',ansilowercase(url))<>0) then s:=URL;
  ShellExecute(handle,nil,PChar(s),nil,nil,SW_SHOWMAXIMIZED);
end;

// zeige eine datei mit dem ihr zugeordneten programm an bzw. starte eine EXE/BAT/COM/PIF-Datei
procedure JKShowFile(F:string);
var dok,dir:String;
    res,dokk,dirr:PChar;
    i:Integer;
    s,s1,err,exen,exep:string;
    CmdLine:PChar;
begin
  dok:=extractfilename(f);
  dir:=extractfilepath(f);
  dokk:=StrAlloc(255);
  dirr:=StrAlloc(255);
  res:=StrAlloc(255);
  StrPCopy(dokk,dok);
  StrPCopy(dirr,dir);

  i:=FindExecutable(dokk,dirr,res);
  StrDispose(dokk);
  StrDispose(dirr);

  s1:=StrPas(res);

  exen:=extractFileName(s1);
  if (ansilowercase(extractfileext(f))='.exe') or (ansilowercase(extractfileext(f))='.com')
    or (ansilowercase(extractfileext(f))='.pif') or (ansilowercase(extractfileext(f))='.bat')
    then begin
      exen:=extractFileName(f);
      exep:=extractFilePath(f);
  end else begin
    exen:=exen+' '+f;
    exep:=extractFilePath(s1);
  end;
  s:=exep+exen;
  CmdLine:=StrAlloc(255);
  StrPCopy(CmdLine,s);
  if exen<>'' then i:=winexec(CmdLine,SW_SHOW) else i:=2;
  StrDispose(CmdLine);
  case i of
    0:err:='zuwenig Speicher oder Datei zerstört';
    2:err:='Anzeigeprogramm nicht gefunden';
    3:err:='Verzeichnis nicht gefunden';
    5:err:='Dateizugriffsfehler im Netz';
    6:err:='Bibliothek forderte separate Datensegmente für jede Task an. ';
    8:err:='Zuwenig Speicher, um die Anwendung zu starten.';
    10:err:='Falsche Windows-Version. ';
    11:err:='Ungültige ausführbare Datei. Entweder keine Windows-Anwendung oder Fehler in der EXE-Datei.';
    12:err:='Anwendung für ein anderes Betriebssystem. ';
    13:err:='Anwendung für MS-DOS 4.0. ';
    14:err:='Typ der ausführbaren Datei unbekannt.';
    15:err:='Versuch, eine Real-Mode-Anwendung (für eine frühere Windows-Version) zu laden. ';
    16:err:='Versuch, eine zweite Instanz einer ausführbaren Datei mit mehreren Datensegmenten, die nicht nur lesbar, laden. ';
    19:err:='Versuch, eine komprimierte ausführbare Datei zu laden. Die Datei muß dekomprimiert werden.';
    20:err:='Ungültige DLL. Eine der DLLs, die benötigt wurde, um die Anwendung auszuführen, war beschädigt.';
    21:err:='Anwendung benötigt Windows-32-Bit-Erweiterungen. ';
    31:err:='Programm unbekannt';
  end;
  if i<32 then MessageDlg('Fehler beim Laden: '+err,mtError,[mbOK],0);
  StrDispose(res);
end;

// konvertiert eine HEX-Zahl in einen Integer
function HextoDec(const S: string): Longint;
var
  HexStr: string;
begin
  if Pos('$', S) = 0 then HexStr := '$' + S
  else HexStr := S;
  Result := StrToIntDef(HexStr, 0);
end;

//string: gibt 'false' für value=false, ansonsten 'true' zurück
function boolToStr(value:boolean):string;
begin
  result:='false';
  if value then result:='true';
end;


// string: gibt true zurück, wenn nzr die in chars angegebenen "Buchstaben" in text vorkommen
function StringConsistsOf(text:string; chars: tjkchars):boolean;
var i:longint;
begin
  result:=true;
  i:=1;
  repeat
    if not(text[i] in chars) then result:=false;
    inc(i);
  until (result=false)or(i>length(text));
end;

// FTP: gibt den Dateinamen aus einem FTP-Dateinamensstring mit Verzeichnissen zurück ('/' statt '\')
function FTPExtractFileName(fn:string):string;
begin
  result:=stringreplace( extractfilename(stringreplace(fn,'/','\',[rfReplaceAll, rfIgnoreCase])) ,'\','/',[rfReplaceAll, rfIgnoreCase])
end;

// Dateien: gibt die Größe der Datei fn in Byte zurück
function filegetsize(fn:string):longint;
var fff:file;
begin
  result:=0;
  if not fileexists(fn) then exit;
  AssignFile(fff, fn);
  Reset(fff);
  result := FileSize(fff);
  closefile(fff);
end;

// Dateien: gibt die Größe der Datei fn in Byte zurück
function getFileDate(fn:string):TDateTime;
begin
  result:=StrtoDateTime('1.1.00');
  if FileAge(fn)=-1 then exit;
  result := FileDateToDateTime(FileAge(fn));
end;

// TTreeView: gibt einen Pfad der Form "Node.name/node.name/" zurück
// wobei '/' durch divider übergeben wird
function GetTreePath(node:TTreeNode;divider:string):string;
var n:TTreeNode;
begin
  result:='';
  n:=node;
  repeat
    n:=n.Parent;
    if n<>nil then result:=result+n.text+divider;
  until n=nil;
//  if length(result)>0 then result:=result+divider;
end;

// FTP: erzeugt einen "Rücksprungpfad" der Form '../../../' von einem Verzeichnis ins Grundverzeichnis
function FTPGetReturn(dir:string):string;
  var sl:TStringList;
      _s:Char;
      ads:string;
      n:longint;
begin
  result:='';
  sl:=TStringList.Create;
  sl.clear;
  if dir<>'' then
    repeat
       ads:='';
      repeat
        _s:=dir[1];
        ads:=ads+_s;
        delete(dir,1,1);
      until (_s in ['/','\'])or(length(dir)<=0);
      sl.Add(ads);
    until (length(dir)<=0);

  if sl.count>0 then
    for n:=0 to sl.count-1 do
      if n=0 then result:=result+'..' else result:=result+'/..';
  sl.free;
end;


// WinAPI/Files: gibt einen, von der WinAPI erzeugten einmaligen Dateinamen für temporäre Dateien zurück
function GetTempFileName:string;
var p : PChar;
    d : PChar;
begin
  p:=StrAlloc(MAX_PATH+1);
  d:=StrAlloc(MAX_PATH+1);
  GetTempPath(MAX_PATH, d);
  windows.GETTEmpFileName(d, '$$', 0, p);
  result:=string(p);
  StrDispose(p);
  StrDispose(d);
  if fileexists(result) then DeleteFile(result);
end;

function getrelativePathEx(file1, file2, relpath:string):string;
var p1:string;
begin
  result:='';
  chdir(extractfilepath(file1));
  p1:=expandfilenAME(file2);
  result:=extractrelativepath(relpath,p1);
//  ShowMEssAGE(file1+'   '+file2+'   '+p1+'   '+relpath+'   '+result);
end;

// JKConnect 3.0: gibt die verlinkten Dateien aus der HTML-Datei filename in sl zurück, relativ zu projpath
procedure ExtractLinkedFiles(projPath, filename:string; sl:TStringList);
var f:system.text;
    line, l, dat, tmp:string;
    position, pos1, i:longint;
    ready, ok:boolean;
begin
  assignfile(f,filename);
  reset(f);
  sl.Clear;
  while not eof(f) do begin
    ReadLn(f,l);
    line:=l;
    //showmessage(line);
    while ((pos('href=',ansilowercase(line))>0)or(pos('href =',ansilowercase(line))>0))and (length(line)>7) do begin
      pos1:=pos('href=',ansilowercase(line)); position:=pos1;
      if pos1=0 then begin pos1:=pos('href =',ansilowercase(line)); position:=pos1; end;
      ready:=false;
      repeat
        if (line[position]='"')or(line[position]='''') then ready:=true; inc(position);
      until (position>length(line))or ready;
      dat:='';
      ready:=false;
      repeat
        if (line[position]='"')or(line[position]='''') then ready:=true
        else dat:=dat+line[position];
        inc(position);
      until (position>length(line))or ready;
      delete(line,1, position);
//      showmessage('Dat:   '+getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath )+'   '+inttostr(position)+' / '+inttostr(length(line)));
      if sl.IndexOf(getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath ))=-1 then
        if (not (pos('#',ansilowercase(dat))>0))and
         (not (pos('ftp:',ansilowercase(dat))>0))and
         (not (pos('javascript:',ansilowercase(dat))>0))and
         (not (pos('<',ansilowercase(dat))>0))and
         (not (pos('>',ansilowercase(dat))>0))and
         (not (pos('vbscript:',ansilowercase(dat))>0))and
         (not (pos('http:',ansilowercase(dat))>0))and
         (not (pos('gropher:',ansilowercase(dat))>0)) and
         (not (pos('telnet:',ansilowercase(dat))>0))and
         (not (pos('mailto:',ansilowercase(dat))>0))and
         (not (pos('news:',ansilowercase(dat))>0)) then begin
           tmp:=getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath );
           ok:=true;
           i:=0;
           repeat
             inc(i);
             if not (tmp[i] in ['a'..'z','A'..'Z','0'..'9','-','_','.','/','\']) then ok:=false;
           until (not ok)or(i=length(tmp));
           if ok then sl.Add(tmp);
         end;
    end;
    line:=l;
    //showmessage(line);
    while ((pos('background=',ansilowercase(line))>0)or(pos('background =',ansilowercase(line))>0))and (length(line)>12) do begin
      pos1:=pos('background=',ansilowercase(line)); position:=pos1;
      if pos1=0 then begin pos1:=pos('background =',ansilowercase(line)); position:=pos1; end;
      ready:=false;
      repeat
        if (line[position]='"')or(line[position]='''') then ready:=true; inc(position);
      until (position>length(line))or ready;
      dat:='';
      ready:=false;
      repeat
        if (line[position]='"')or(line[position]='''') then ready:=true
        else dat:=dat+line[position];
        inc(position);
      until (position>length(line))or ready;
      delete(line,1, position);
//      showmessage('Dat:   '+getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath )+'   '+inttostr(position)+' / '+inttostr(length(line)));
      if sl.IndexOf(getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath ))=-1 then
        if (not (pos('#',ansilowercase(dat))>0))and
         (not (pos('ftp:',ansilowercase(dat))>0))and
         (not (pos('javascript:',ansilowercase(dat))>0))and
         (not (pos('<',ansilowercase(dat))>0))and
         (not (pos('>',ansilowercase(dat))>0))and
         (not (pos('vbscript:',ansilowercase(dat))>0))and
         (not (pos('http:',ansilowercase(dat))>0))and
         (not (pos('gropher:',ansilowercase(dat))>0)) and
         (not (pos('telnet:',ansilowercase(dat))>0))and
         (not (pos('mailto:',ansilowercase(dat))>0))and
         (not (pos('news:',ansilowercase(dat))>0)) then begin
           tmp:=getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath );
           ok:=true;
           i:=0;
           repeat
             inc(i);
             if not (tmp[i] in ['a'..'z','A'..'Z','0'..'9','-','_','.','/','\']) then ok:=false;
           until (not ok)or(i=length(tmp));
           if ok then sl.Add(tmp);
         end;
    end;
    line:=l;
    while ((pos('src=',ansilowercase(line))>0)or(pos('src =',ansilowercase(line))>0))and (length(line)>7) do begin
      pos1:=pos('src=',ansilowercase(line)); position:=pos1;
      if pos1=0 then begin pos1:=pos('src =',ansilowercase(line)); position:=pos1; end;
      ready:=false;
      repeat
        if (line[position]='"')or(line[position]='''') then ready:=true; inc(position);
      until (position>length(line))or ready;
      dat:='';
      ready:=false;
      repeat
        if (line[position]='"')or(line[position]='''') then ready:=true
        else dat:=dat+line[position];
        inc(position);
      until (position>length(line))or ready;
      delete(line,1, position);
//      showmessage('Dat:   '+getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath )+'   '+inttostr(position)+' / '+inttostr(length(line)));
      if sl.IndexOf(getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath ))=-1 then
        if (not (pos('#',ansilowercase(dat))>0))and
         (not (pos('ftp:',ansilowercase(dat))>0))and
         (not (pos('javascript:',ansilowercase(dat))>0))and
         (not (pos('<',ansilowercase(dat))>0))and
         (not (pos('>',ansilowercase(dat))>0))and
         (not (pos('vbscript:',ansilowercase(dat))>0))and
         (not (pos('http:',ansilowercase(dat))>0))and
         (not (pos('gropher:',ansilowercase(dat))>0)) and
         (not (pos('telnet:',ansilowercase(dat))>0))and
         (not (pos('mailto:',ansilowercase(dat))>0))and
         (not (pos('news:',ansilowercase(dat))>0)) then  begin
           tmp:=getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath );
           ok:=true;
           i:=0;
           repeat
             inc(i);
             if not (tmp[i] in ['a'..'z','A'..'Z','0'..'9','-','_','.','/','\']) then ok:=false;
           until (not ok)or(i=length(tmp));
           if ok then sl.Add(tmp);
         end;
    end;
    line:=l;
    while ((pos('lowsrc=',ansilowercase(line))>0)or(pos('lowsrc =',ansilowercase(line))>0))and (length(line)>7) do begin
      pos1:=pos('lowsrc=',ansilowercase(line)); position:=pos1;
      if pos1=0 then begin pos1:=pos('lowsrc =',ansilowercase(line)); position:=pos1; end;
      ready:=false;
      repeat
        if (line[position]='"')or(line[position]='''') then ready:=true; inc(position);
      until (position>length(line))or ready;
      dat:='';
      ready:=false;
      repeat
        if (line[position]='"')or(line[position]='''') then ready:=true
        else dat:=dat+line[position];
        inc(position);
      until (position>length(line))or ready;
      delete(line,1, position);
//      showmessage('Dat:   '+getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath )+'   '+inttostr(position)+' / '+inttostr(length(line)));

      if sl.IndexOf(getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath ))=-1 then
        if (not (pos('#',ansilowercase(dat))>0))and
         (not (pos('ftp:',ansilowercase(dat))>0))and
         (not (pos('javascript:',ansilowercase(dat))>0))and
         (not (pos('vbscript:',ansilowercase(dat))>0))and
         (not (pos('<',ansilowercase(dat))>0))and
         (not (pos('>',ansilowercase(dat))>0))and
         (not (pos('http:',ansilowercase(dat))>0))and
         (not (pos('gropher:',ansilowercase(dat))>0)) and
         (not (pos('telnet:',ansilowercase(dat))>0))and
         (not (pos('mailto:',ansilowercase(dat))>0))and
         (not (pos('news:',ansilowercase(dat))>0)) then  begin
           tmp:=getRelativePathEx(filename,stringreplace(dat,'/','\',[rfReplaceAll, rfIgnoreCase]),projpath );
           ok:=true;
           i:=0;
           repeat
             inc(i);
             if not (tmp[i] in ['a'..'z','A'..'Z','0'..'9','-','_','.','/','\']) then ok:=false;
           until (not ok)or(i=length(tmp));
           if ok then sl.Add(tmp);
         end;
    end;
  end;
  closefile(f);
end;

// Files: fügt in die Text-Datei f die Datei filename ab der aktuellen Position ein
procedure InsertTextFile(var f:system.text; filename:string);
var ifile:system.text;
    s:string;
begin
  Assignfile(ifile, filename);
  reset(ifile);
  while not eof(ifile) do begin
    Readln(ifile, s);
    WriteLn(f,s);
  end;
  closefile(ifile);
end;

// Streams: schreibt den Text str in den Stream s
// Form: ----|-------------
//      länge|text
procedure WriteString(s:TStream; str:ansistring);
var leng, i:longword;
begin
  leng:=length(str);
  s.write(leng, sizeof(leng));
  if leng>0 then
    for i:=1 to leng do
      s.write(str[i], sizeof(str[i]));
end;

// Streams: liest einen string aus dem Stream s, Gegenstück zu 'WriteString' (s.o.)
// Form: ----|-------------
//      länge|text
function ReadString(s:TStream):ansistring;
var leng, i:longword;
    ch:char;
begin
  result:='';
  s.read(leng, sizeof(leng));
  if leng>0 then
    for i:=1 to leng do begin
      s.read(ch, sizeof(ch));
      result:=result+ch;
    end;
end;


function DelBSpace(const S: string): string;
var
  I, L: Integer;
begin
  L := Length(S);
  result:=s;
  if l<=0 then exit;
  I := 1;
  while (I <= L) and (S[I] = ' ') and (i<=length(s)) do Inc(I);
  Result := Copy(S, I, MaxInt);
end;

function DelESpace(const S: string): string;
var
  I: Integer;
begin
  I := Length(S);
  result:=s;
  if i<=0 then exit;
  while (I > 0) and (S[I] = ' ') and (i<=length(s)) do Dec(I);
  Result := Copy(S, 1, I);
end;

function DelRSpace(const S: string): string;
begin
  Result := DelBSpace(DelESpace(S));
end;

function NumberOfLines(text: string): longint;
var i:longint;
begin
  result:=0;
  for i:=1 to length(text) do begin
    if text[i] =#13 then inc(result);
    if i>1 then
      if (text[i-1]<>#13)and(text[i] =#10) then inc(result);
  end;
end;

procedure ShowErrorMessage(text: string);
begin
  MessageDlg(text, mtError, [mbOK], 0);
end;

// kürzt einen Vornamen auf die Initialen ab
function ShortenPrename(name: string): string;
var s4:string;
    i:longint;
begin
      if (name<>'') then begin
        s4:='';
        i:=2;
        s4:=name[1]+'.';
        repeat
          if (name[i]=' ') then begin
            i:=i+1;
            s4:=s4+' '+name[i]+'.';
          end;
          if (name[i]='-') then begin
            i:=i+1;
            s4:=s4+'-'+name[i]+'.';
          end;
          inc(i);
        until i>=length(name);
      end;
      result:=s4;
end;

end.