File:  [mozdev] / mozptch / unitfunc.pas
Revision 1.3: download - view: text, annotated - select for diffs - revision graph
Sun May 30 19:51:15 2004 UTC (16 years ago) by oertel
Branches: MAIN
CVS tags: version_30_05_04, HEAD
-Linux support ready for delivery (beta)
-New Variables for EmailAddress, ncoming and outgoing server
-INI-Files debuged
- new bin zip file

(* Copyright (c) uib umwelt informatik buero gmbh (www.uib.de)
 This sourcecode is owned by uib
 and published under the Terms of the General Public License.
#*###CVS_HEAD_START###******************************************************
# $Id: unitfunc.pas,v 1.3 2004/05/30 19:51:15 oertel Exp $
#
#*###EXCLUDE_CVS_LOG###*****************************************************
# History:
# ========
#
# $Log: unitfunc.pas,v $
# Revision 1.3  2004/05/30 19:51:15  oertel
# -Linux support ready for delivery (beta)
# -New Variables for EmailAddress, ncoming and outgoing server
# -INI-Files debuged
# - new bin zip file
#
# Revision 1.1  2004/03/14 12:49:07  oertel
# Initial commit version 9.29
#
*)
unit unitfunc;

interface
{$IFDEF MSWINDOWS}

uses

  wintypes, winprocs,  FileCtrl,
  Sysutils, classes;



Type
  TcpSpecify = Byte;


Const
  (* additive Konstanten für den Typ TcpSpecify *)
  cpFlat                       = 0;  (* keine Rekursion und keine Subdirectories,
                                      unbegrenztes OverWrite *)
  cpCreateEmptySubdirectories  = 1;
  cpRecursive                  = 2;
  cpVersionControl             = 4;  (* Overwrite bei Dateien mit Extension in ExtensionsForVersionsControl
                                      nur nach vorheriger Versionskontrolle *)
  cpDateControl                = 8;  (* kein Overwrite bei Dateien mit Extension EXE wenn Zieldatei jüngeren Datums *)
  cpUpdate                     = 16; (* kein Overwrite, wenn Zieldatei jünger oder gleich alt *)
  cpNoOverwrite                = 32; (* kein Overwrite *)
  cpExtractLHA                 = 64; (* beim Kopieren Lharc-komprimierte Dateien dekomprimieren *)

function AllDelete(Const Filename : String; recursive, ignoreReadOnly : Boolean; var LastFehler: string) : Boolean;
{Aus dem winst übernommen, Änderungen: procedure -> function, LastFehler dazu}

Function AllCopy
(const SourceMask, Target: String; cpSpecify : TcpSpecify;
 preserveDate, preserveAttr : boolean;
 var MainFehler : string): Boolean;
{Aus dem winst übernommen, Änderungen: procedure -> function, MainFehler dazu}

Function FileCopy
      (Const sourcefilename, targetfilename: String;
       preserveDate, preserveAttr : boolean;
       Var problem : string)
      : Boolean;

function ValueOfEnvVar (Const VarName : String) : String;

function PointerAufString (Alpha : String) : PChar;

function FileGetWriteAccess (Const Filename : String; var ActionInfo : String ) : Boolean;
{$ENDIF }
implementation
{$IFDEF MSWINDOWS}


function IsDirectory (Const FName : String) : Boolean;
  Var
    Complete, pureName: String;
  Begin
    Complete := ExpandFilename (Fname);
    pureName := ExtractFileName (Complete);
    if
    (pos ('*', pureName) = 0) and (pos ('?', pureName) = 0)
    and
    (directoryExists (Complete)
    or (copy (Complete, length (Complete)-1, 2) = ':\'))
    then Result := true
    else Result := false;
  End;



 function SizeOfFile (FName : String) : LongInt;
   Var
   SearchRec : TSearchRec;
  begin
     if findfirst (FName, faAnyFile, SearchRec) = 0
     then
       Result := SearchRec.Size
     else
       Result := -1;
     sysutils.findclose (SearchRec);
  end;


 Function FileCopy
      (Const sourcefilename, targetfilename: String;
       preserveDate, preserveAttr : boolean;
       Var problem : string)
      : Boolean;

     (* problem enthält eventuell Hinweis auf fehlenden Plattenplatz *)

  Var
    S, T: TFileStream;

    Date : Longint;
    Attr, targetAttr : Integer;
    Handle : Integer;
    fileresult : Integer;

    TargetDriveNo : Byte;
    SourceSize, FreeOnDisk : {$IFDEF WIN32 } INT64 {$ELSE } LongInt {$ENDIF };
    Fullname : String;

    sourcefileopened :  Boolean;

  Begin
    Result := false;
    problem := '';


    Fullname := Expandfilename (targetfilename);
    TargetDriveNo := ord (Fullname [1]) - ord ('A') + 1;
    SourceSize := SizeOfFile (sourcefilename);
    {$IFDEF MSWINDOWS}
    FreeOnDisk := diskfree (TargetDriveNo);

    if FreeOnDisk >= 0 then
        if SourceSize > FreeOnDisk - 10000
           then
                 problem :=
                         'Problem: Sourcefile has ' +  IntToStr (SourceSize) + ' bytes, free on disk.'
                         + Fullname[1] + ':  '   + IntToStr (FreeOnDisk);
    {$ENDIF}
    Handle := fileopen (sourcefilename, fmOpenRead);
    Date := filegetdate (Handle);
    fileclose (handle);

    { mit WinApi-Aufruf

    pSourceFilename := PointerAufString (SourceFilename);
    pTargetFilename := PointerAufString (TargetFilename);

    result := copyFile (pSourceFilename, pTargetFilename, true);
    if not result
    then
    Begin
      problem := problem + ' Errorcode ' + IntToStr (GetLastError);

    DisposeString (pSourceFilename);
    DisposeString (pTargetFilename);
                        }
    {mit Stream-Objekten}

    Attr := filegetattr (sourcefilename);

    sourcefileopened := false;
    try
     S := TFileStream.Create (sourcefilename, fmOpenRead  or fmShareDenyWrite);
     sourcefileopened := true;
    except
     problem := sourcefilename + ' could not be opened';
    end;
    if not sourcefileopened then exit;

    // Dafür sorgen, das vorhandene Datei überschreibbar ist....
    if FileExists(targetfilename) then
    begin
     targetAttr := FileGetAttr(targetfilename);
     if targetAttr and faReadOnly <> 0 then
     begin
      fileresult := FileSetAttr(targetfilename, targetAttr - faReadOnly);
      if fileresult >0 then
      begin
       problem := 'Error: Attribut not set for: '+targetfilename+', error ' + IntToStr (fileresult) ;
      end;
     end;
    end;

    try
      T := TFileStream.Create( targetfilename, fmOpenWrite or fmCreate );

    except
      S.free;
      problem := problem + 'Target '+targetfilename+' could not be opened, fileattribute ' + IntToStr (attr);
      exit;
    end;


    try
      T.CopyFrom(S, S.Size ) ;

    except
      T.Free;
      S.Free;
      problem := problem + 'Error while copying.';
      exit;
    end;

    T.Free;
    S.Free;


    if preserveDate then
    begin
     Handle := fileopen (targetfilename, fmOpenWrite + fmShareDenyWrite);
     fileresult := filesetdate (Handle, Date);
     if fileresult >0 then
     begin
      problem := 'Date not set, error ' + IntToStr (fileresult) ;
     end;
     fileclose (handle);
    end;

    if preserveAttr then
    begin
     fileresult := filesetattr (targetfilename, attr);
     if fileresult >0 then
     begin
      problem := 'Attribut not set, error ' + IntToStr (fileresult) ;
     end;
    end;
    Result := true;
//    FBar.Gauge1.Progress := FBar.Gauge1.Progress +1;
//    FBar.Update;
  End;




Function FileCheckDate
         (Const Sourcefilename, Targetfilename: String; OverwriteIfEqual: Boolean) : Boolean;
 (* Assumption: Both files exist *)
  Var
   Handle : Integer;
   Date1, Date2 : LongInt;

begin
  Handle := fileopen (Sourcefilename, fmOpenRead);
  Date1 := filegetdate (Handle);
  fileclose (handle);
  Handle := fileopen (Targetfilename, fmOpenRead);
  Date2 := filegetdate (Handle);
  fileclose (handle);
  if (Date2 < Date1) or ((Date2 = Date1) and OverwriteIfEqual)
  then
  Begin
    Result := true;
  End
  else
  Begin
    Result := false;
  End
end;


Function AllCopy
(const SourceMask, Target: String; cpSpecify : TcpSpecify;
 preserveDate, preserveAttr : boolean;
 var MainFehler : string): Boolean;

Var
  FileFound : Boolean;
  Recursion_Level : Integer;
  TeilFehler : string;


  Procedure AllCopyRecursive
  (var Recursion_Level : Integer; SourceMask, Target: String;
//   preserveDate, preserveAttr : boolean;
   Var FileFound : Boolean; var cpSpecify : TcpSpecify);

  Var
    CompleteName, Extension,
    SourcePath, SourceFilemask, SourceName,
    TargetPath, TargetFilemask, TargetName: String;

    FindResultcode: Integer;
    FileAttr : Integer;
    SearchResult : TSearchRec;

    FileFoundOnThisLevel, FileFoundOnADeeperLevel: Boolean;
    DirectoryExisted : Boolean;
    DirectoryError : Integer;


    Procedure ToCopyOrNotToCopy (Const SourceName, TargetName : String);
    var
        CopyShallTakePlace : Boolean;
    Begin
     if SourceName = TargetName
     then
     begin
     end
     else
     begin
       CopyShallTakePlace := true;

  (*      if cpSpecify and cpVersionControl = cpVersionControl
       then
       Begin
         Extension := UpperCase (ExtractFileExt (TargetName));
         delete (Extension, 1, 1);
         if StrIsIn (Extension, ExtensionsForVersionControl) > 0
         then
         CopyShallTakePlace := FileCheckVersions (SourceName, TargetName);
       End; *)

       if CopyShallTakePlace and FileExists (TargetName) then
       begin
         if cpSpecify and cpNoOverwrite = cpNoOverwrite
         then
         Begin
          CopyShallTakePlace := false;
         End
         else if cpSpecify and cpUpdate = cpUpdate
         then
         Begin
           CopyShallTakePlace := FileCheckDate (SourceName, TargetName, false)
         End
         else if cpSpecify and cpDateControl = cpDateControl
         then
         Begin
           Extension := UpperCase (ExtractFileExt (TargetName));
           delete (Extension,1,1);
           if (Extension = 'EXE')
           then
           CopyShallTakePlace := FileCheckDate (SourceName, TargetName, true)
         End
         else
         begin
         end;
       End;

       if CopyShallTakePlace
       then
       begin
         if FileCopy (SourceName, TargetName, preserveDate,
                      preserveAttr, TeilFehler)
         then
         else
             begin
                  MainFehler := MainFehler + TeilFehler;
                  result := false;
             end;
       end;
     end;
    End;


  Begin
    Recursion_Level := Recursion_Level + 1;
    FileFoundOnThisLevel := false;

    (* SourceMask auf Standardform bringen *)

    CompleteName := ExpandFileName (SourceMask);
    SourcePath := ExtractFilePath (CompleteName);
    if SourcePath [length (SourcePath)] <> '\' then
       SourcePath := SourcePath + '\';
    SourceFilemask := ExtractFileName (CompleteName);
    if SourceFilemask = '' then SourceFilemask := '*.*';

    (* TargetMask auf Standardform bringen *)
    CompleteName := ExpandFileName (Target);
    TargetPath   := CompleteName;
    if TargetPath [length (TargetPath)] <> '\' then
       TargetPath := TargetPath + '\';


    if (length (TargetPath) > 1) and (TargetPath [length (TargetPath) - 1] = ':')
    then
      (* TargetPath is e.g. c:\, that is, not a file but a volume identifier *)
    else
    Begin
      CompleteName := copy (TargetPath, 1, length (TargetPath) - 1);

      if fileGetAttr (CompleteName) and faDirectory = 0
      then
      begin
        exit;
      end;
    End;

    FindResultcode
    := FindFirst (SourcePath + SourceFilemask, faAnyfile - faDirectory - faVolumeId,
                  SearchResult);

    if FindResultcode = 0
    then FileFoundOnThisLevel := true
    else
    Begin
    End;

    while FindResultcode = 0
    do
    Begin
      SourceName := SourcePath + SearchResult.Name;
      TargetName := TargetPath + SearchResult.Name;


      ToCopyOrNotToCopy (SourceName, TargetName);

      FindResultcode := FindNext (SearchResult);
    end;

   FindClose (SearchResult);

   (* Subdirectories im Source-Verzeichnis suchen
     und gegebenenfalls im Targetverzeichnis neu anlegen *)

    FindResultcode
    := FindFirst (SourcePath + '*.*', faDirectory(* faAnyFile *),
                  SearchResult);


    while FindResultcode = 0
    do
    Begin
      if (SearchResult.Attr and faDirectory = faDirectory) and
         (SearchResult.Name <> '.') and
         (SearchResult.Name <> '..')
      then
      Begin
        DirectoryError := 0;

        TargetName := TargetPath + SearchResult.Name;
        FileAttr := FileGetAttr (TargetName);

        if (FileAttr >= 0)
        then
        Begin

          if FileAttr = faDirectory
          then
          Begin
            DirectoryExisted := true;
          End
          else
          Begin
            DirectoryError := 1;
          End
        end
        else
        begin
          DirectoryExisted := false;
          try
            mkdir (TargetName);
          except
            DirectoryError := 2;
          end;

        end;

        FileFoundOnADeeperLevel := false;

        if ((cpSpecify and cpRecursive) = cpRecursive)
            and (DirectoryError = 0)
        then
          (* Rekursion *)
        Begin

          AllCopyRecursive
          (Recursion_Level, SourcePath + SearchResult.Name + '\'+ SourceFileMask,
           TargetName, FileFoundOnADeeperLevel, cpSpecify);
          if FileFoundOnADeeperLevel then FileFoundOnThisLevel := true;

        End;

        if ((cpSpecify and cpCreateEmptySubdirectories) = 0)
            and not FileFoundOnADeeperLevel and not DirectoryExisted
            and (DirectoryError = 0)
        then
          (* angelegtes directory wieder entfernen *)
          rmdir (TargetName);


      end;

      FindResultcode := FindNext (SearchResult);
    end;

    FindClose (SearchResult);

    FileFound := FileFoundOnThisLevel (* resp. on a deeper level *);
    Recursion_Level := Recursion_Level - 1;
  End;

Begin

  result := true;
  MainFehler := '';
  TeilFehler := '';
  FileFound := false;
  Recursion_Level := -1;


  AllCopyRecursive
      (Recursion_Level, SourceMask, Target, FileFound, cpSpecify);

End;



function AllDelete(Const Filename : String; recursive, ignoreReadOnly : Boolean; var LastFehler: string):Boolean;
  Var
    CompleteName, FileMask : String;
    DeleteDeeperDir,
    DeleteStartDir : Boolean;

  Procedure ExecDelete
  (Const CompleteName : String; DeleteDir : Boolean);
  var
    Filename,
    FileMask, OrigPath : String;
    FindResultcode: Integer;
    SearchResult : TSearchRec;

    errorNo : Integer;
    attr : Integer;

  begin
          (* Completename zerlegen *)
    OrigPath := ExtractFilePath (CompleteName);
    (* endet, wie CompleteName sowohl ursprünglich
       als auch in der Rekursion konstruiert ist, stets auf \ *)
    Filemask := ExtractFileName (CompleteName);

          (* zuerst Subdirectories suchen, so daß per Rekursion die unterste Ebene zuerst gelöscht
        wird *)
    if recursive then
    Begin
      FindResultcode := FindFirst (OrigPath + '*.*', faDirectory (* faAnyFile *),
                                   SearchResult);
      while FindResultcode = 0
      do
      Begin
        if (SearchResult.Attr and faDirectory = faDirectory) and
           (SearchResult.Name <> '.') and
           (SearchResult.Name <> '..')
        then
           ExecDelete
           (OrigPath + SearchResult.Name + '\' + FileMask, DeleteDeeperDir);
        FindResultcode := FindNext (SearchResult);
      End;
      sysutils.findclose (SearchResult);
    End;

      (* jetzt Suche im Verzeichnis selbst *)
    if Filemask = ''
    then
      Filemask := '*.*';

    FindResultcode := FindFirst (OrigPath + Filemask, faAnyFile - faDirectory, SearchResult);

    (* if FindResultcode <> 0
    then
    Begin
      LogS := LogSIndent(LogDatei.LogSIndentLevel  + 1)
            + 'No file found in ' + OrigPath'
      LogDatei.DependentAdd (LogS, LevelComplete);
    End; *)

    while FindResultcode = 0
    do
    Begin
      Filename := OrigPath + SearchResult.Name;
      Attr := sysutils.FileGetAttr (Filename);
      if Attr and faReadOnly = faReadOnly
      then
      Begin
         if ignoreReadOnly
        then
        Begin
          Attr := Attr and (not faReadOnly);

          ErrorNo := sysutils.FileSetAttr (Filename, Attr);
          if ErrorNo <> 0 then
             begin
                  LastFehler := 'Readonly-Attribut konnte nicht zurückgesetzt werden.';
                  result := false;
             end;
        End
        else
        Begin
          LastFehler := 'Datei konnte nicht gelöscht werden.';
          result := false;
        End;
      End;

      if Attr and faReadOnly = 0
      then
      Begin
        if sysutils.DeleteFile (OrigPath + SearchResult.Name) = False then
           begin
                LastFehler := 'Datei ' + OrigPath + SearchResult.Name + ' could not be deleted';
                result := false;
           end;
      End;

      FindResultcode := FindNext (SearchResult);
    End;

    sysutils.findclose (SearchResult);

    if DeleteDir
    then
      (* zum Schluß der Behandlung einer Verzeichnisebene
         gegebenfalls das Verzeichnis selbst verschwinden lassen *)
    Begin
      delete (OrigPath, length (OrigPath), 1);
      try
        rmDir (OrigPath);
      except
        LastFehler := 'Verzeichnis ' +  OrigPath + ' konnte nicht gelöscht werden.';
        result := False;
      end;
    End;

  end; (* ExecDelete *)


Begin
  result := true;
  LastFehler := '';
  (* Filename aufbereiten *)
  CompleteName := ExpandFileName (Filename);

       (*  if (FileGetAttr (CompleteName) and faDirectory = faDirectory)
       funktioniert nicht!! *)
  if isDirectory (CompleteName)
  and (CompleteName [length (CompleteName)] <> '\')
  then
    CompleteName := CompleteName + '\';



  Filemask := ExtractFileName (CompleteName);

  DeleteStartDir := false;
  DeleteDeeperDir := false;
  if (Filemask = '') or (Filemask='*.*')
  then
    DeleteDeeperDir := true;
  if Filemask = ''
  then
    DeleteStartDir := true;

  (* Starten *)
  if isDirectory (ExtractFilePath (CompleteName))
  then
    ExecDelete (CompleteName, DeleteStartDir);
end;



function ValueOfEnvVar (Const VarName : String) : String;

{$IFDEF WIN32 }
   var
     requiredLength : Integer;

   function GetEnVar (Const VarName : String; Var Value : String; MaxLength : Integer; Var RequiredLength : Integer) : Integer;
     (* liefert -1, wenn die Variable nicht gefunden wurde
        0, wenn MaxLength zu klein für die Aufnahme des Wertes ist
        1, wenn der Wert erfolgreich bestimmt wurde *)
   Var
     lpName : PChar;
     lpBuffer : PChar;
     nSize : DWord;

     ReturnSize : DWord;

   begin
    lpName := PChar (Varname);
    nSize := MaxLength + 1;
    GetMem (lpBuffer, nSize);
    ReturnSize := winprocs.GetEnvironmentVariable(lpName, lpBuffer, nSize);

    if ReturnSize = 0
    then
    Begin
      Value := '/* not found */';
      requiredLength := 0;
      result := -1;
    End
    else
    if ReturnSize < nSize
    then
    Begin
      Value := StrPas (lpBuffer);
      RequiredLength := ReturnSize;
      result := 1;
    End
    else
    Begin
      Value :=
        IntToStr (nSize) + ' /* required ' + IntToStr (ReturnSize) + ' */';
      RequiredLength := ReturnSize - 1;
      result := 0;
    End;


    FreeMem (lpBuffer);  lpBuffer := nil;

   end;

  begin
    if GetEnVar (VarName, result, 255, RequiredLength) = 1
    then
  end;

{$ELSE }

  var
   ptr: PChar;
   Done: BOOLEAN;
   found : Boolean;
   inVarName : Boolean;
   EnvVar : String;
  begin
   ptr :=   GetDOSEnvironment;
   Done := FALSE;
   EnvVar := '';
   result := '';
   inVarName := true;
   found := false;

   WHILE NOT Done and not found DO
   BEGIN
     if ptr^ = #0 then
     Begin
       if upperCase (EnvVar) = upperCase (VarName)
       then
         (* Ende bei gefundenem Wert *)
         found := true
       else
       Begin
         INC(ptr);
         if ptr^ = #0
         then
           Done := TRUE
           (* Ende bei nicht gefundenem Wert *)
         else
           (* beginne nächste Variable zu rekonstruieren *)
         Begin
           inVarName := true;
           EnvVar := '';
           result := '';
           EnvVar := EnvVar + ptr^;
         End
       End;
     End
     else if ptr^ = '='
     then
       inVarName := false
     else
       if inVarName
       then EnvVar := EnvVar + ptr^
       else result := result + ptr^;
      INC(ptr);
   END;

   if not found then result := '';

  end;
{$ENDIF }

  function PointerAufString (Alpha : String) : PChar;
  begin
    {$IFDEF WIN32 }
      Result := PChar (Alpha);
    {$ELSE}
      Result := StrAlloc (length (Alpha) + 1);
      StrPLCopy (Result, Alpha, length (Alpha));
    {$ENDIF }
  end;


  function FileGetWriteAccess (Const Filename : String; var ActionInfo : String ) : Boolean;
    var
    Attr : Integer;
    ErrorNo : Integer;
   Begin
     result := true;
     ActionInfo := '';
     if not FileExists (Filename)
     then exit;
     Attr := sysutils.FileGetAttr (Filename);
     if Attr and faReadOnly = faReadOnly
     then
     Begin
       Attr := Attr and (not faReadOnly);

       ErrorNo := sysutils.FileSetAttr (Filename, Attr);
       if ErrorNo = 0
       then
         ActionInfo := 'Readonly-attribute of file "' + Filename + '" eliminated'
       else
       Begin
         result := false;
         ActionInfo := 'Readonly-attribute of file "' + Filename + '" could not be eliminated, Code '
                   + IntToStr (ErrorNo)
                   {$IFDEF WIN32 }
                   + ' (' + SysErrorMessage (ErrorNo) + ')'
                   {$ENDIF WIN32 };
       End;
     End;
   End;



{$ENDIF }
end.

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>