Annotation of mozptch/unitfunc.pas, revision 1.3

1.1       oertel      1: (* Copyright (c) uib umwelt informatik buero gmbh (www.uib.de)
                      2:  This sourcecode is owned by uib
                      3:  and published under the Terms of the General Public License.
                      4: #*###CVS_HEAD_START###******************************************************
1.2       oertel      5: # $Id: unitfunc.pas,v 1.1 2004/03/14 12:49:07 oertel Exp $
1.1       oertel      6: #
                      7: #*###EXCLUDE_CVS_LOG###*****************************************************
                      8: # History:
                      9: # ========
                     10: #
1.2       oertel     11: # $Log: unitfunc.pas,v $
                     12: # Revision 1.1  2004/03/14 12:49:07  oertel
                     13: # Initial commit version 9.29
                     14: #
1.1       oertel     15: *)
                     16: unit unitfunc;
                     17: 
                     18: interface
1.3     ! oertel     19: {$IFDEF MSWINDOWS}
1.1       oertel     20: 
1.3     ! oertel     21: uses
1.1       oertel     22: 
1.2       oertel     23:   wintypes, winprocs,  FileCtrl,
                     24:   Sysutils, classes;
1.1       oertel     25: 
                     26: 
                     27: 
                     28: Type
                     29:   TcpSpecify = Byte;
                     30: 
                     31: 
                     32: Const
                     33:   (* additive Konstanten für den Typ TcpSpecify *)
                     34:   cpFlat                       = 0;  (* keine Rekursion und keine Subdirectories,
                     35:                                       unbegrenztes OverWrite *)
                     36:   cpCreateEmptySubdirectories  = 1;
                     37:   cpRecursive                  = 2;
                     38:   cpVersionControl             = 4;  (* Overwrite bei Dateien mit Extension in ExtensionsForVersionsControl
                     39:                                       nur nach vorheriger Versionskontrolle *)
                     40:   cpDateControl                = 8;  (* kein Overwrite bei Dateien mit Extension EXE wenn Zieldatei jüngeren Datums *)
                     41:   cpUpdate                     = 16; (* kein Overwrite, wenn Zieldatei jünger oder gleich alt *)
                     42:   cpNoOverwrite                = 32; (* kein Overwrite *)
                     43:   cpExtractLHA                 = 64; (* beim Kopieren Lharc-komprimierte Dateien dekomprimieren *)
                     44: 
                     45: function AllDelete(Const Filename : String; recursive, ignoreReadOnly : Boolean; var LastFehler: string) : Boolean;
                     46: {Aus dem winst übernommen, Änderungen: procedure -> function, LastFehler dazu}
                     47: 
                     48: Function AllCopy
                     49: (const SourceMask, Target: String; cpSpecify : TcpSpecify;
                     50:  preserveDate, preserveAttr : boolean;
                     51:  var MainFehler : string): Boolean;
                     52: {Aus dem winst übernommen, Änderungen: procedure -> function, MainFehler dazu}
                     53: 
                     54: Function FileCopy
                     55:       (Const sourcefilename, targetfilename: String;
                     56:        preserveDate, preserveAttr : boolean;
                     57:        Var problem : string)
                     58:       : Boolean;
                     59: 
                     60: function ValueOfEnvVar (Const VarName : String) : String;
                     61: 
                     62: function PointerAufString (Alpha : String) : PChar;
                     63: 
                     64: function FileGetWriteAccess (Const Filename : String; var ActionInfo : String ) : Boolean;
1.3     ! oertel     65: {$ENDIF }
1.1       oertel     66: implementation
1.3     ! oertel     67: {$IFDEF MSWINDOWS}
1.1       oertel     68: 
                     69: 
                     70: function IsDirectory (Const FName : String) : Boolean;
                     71:   Var
                     72:     Complete, pureName: String;
                     73:   Begin
                     74:     Complete := ExpandFilename (Fname);
                     75:     pureName := ExtractFileName (Complete);
                     76:     if
                     77:     (pos ('*', pureName) = 0) and (pos ('?', pureName) = 0)
                     78:     and
                     79:     (directoryExists (Complete)
                     80:     or (copy (Complete, length (Complete)-1, 2) = ':\'))
                     81:     then Result := true
                     82:     else Result := false;
                     83:   End;
                     84: 
                     85: 
                     86: 
                     87:  function SizeOfFile (FName : String) : LongInt;
                     88:    Var
                     89:    SearchRec : TSearchRec;
                     90:   begin
                     91:      if findfirst (FName, faAnyFile, SearchRec) = 0
                     92:      then
                     93:        Result := SearchRec.Size
                     94:      else
                     95:        Result := -1;
                     96:      sysutils.findclose (SearchRec);
                     97:   end;
                     98: 
                     99: 
                    100:  Function FileCopy
                    101:       (Const sourcefilename, targetfilename: String;
                    102:        preserveDate, preserveAttr : boolean;
                    103:        Var problem : string)
                    104:       : Boolean;
                    105: 
                    106:      (* problem enthält eventuell Hinweis auf fehlenden Plattenplatz *)
                    107: 
                    108:   Var
                    109:     S, T: TFileStream;
                    110: 
                    111:     Date : Longint;
                    112:     Attr, targetAttr : Integer;
                    113:     Handle : Integer;
                    114:     fileresult : Integer;
                    115: 
                    116:     TargetDriveNo : Byte;
                    117:     SourceSize, FreeOnDisk : {$IFDEF WIN32 } INT64 {$ELSE } LongInt {$ENDIF };
                    118:     Fullname : String;
                    119: 
                    120:     sourcefileopened :  Boolean;
                    121: 
                    122:   Begin
                    123:     Result := false;
                    124:     problem := '';
                    125: 
                    126: 
                    127:     Fullname := Expandfilename (targetfilename);
                    128:     TargetDriveNo := ord (Fullname [1]) - ord ('A') + 1;
                    129:     SourceSize := SizeOfFile (sourcefilename);
1.2       oertel    130:     {$IFDEF MSWINDOWS}
1.1       oertel    131:     FreeOnDisk := diskfree (TargetDriveNo);
                    132: 
                    133:     if FreeOnDisk >= 0 then
                    134:         if SourceSize > FreeOnDisk - 10000
                    135:            then
                    136:                  problem :=
                    137:                          'Problem: Sourcefile has ' +  IntToStr (SourceSize) + ' bytes, free on disk.'
                    138:                          + Fullname[1] + ':  '   + IntToStr (FreeOnDisk);
1.2       oertel    139:     {$ENDIF}
1.1       oertel    140:     Handle := fileopen (sourcefilename, fmOpenRead);
                    141:     Date := filegetdate (Handle);
                    142:     fileclose (handle);
                    143: 
                    144:     { mit WinApi-Aufruf
                    145: 
                    146:     pSourceFilename := PointerAufString (SourceFilename);
                    147:     pTargetFilename := PointerAufString (TargetFilename);
                    148: 
                    149:     result := copyFile (pSourceFilename, pTargetFilename, true);
                    150:     if not result
                    151:     then
                    152:     Begin
                    153:       problem := problem + ' Errorcode ' + IntToStr (GetLastError);
                    154: 
                    155:     DisposeString (pSourceFilename);
                    156:     DisposeString (pTargetFilename);
                    157:                         }
                    158:     {mit Stream-Objekten}
                    159: 
                    160:     Attr := filegetattr (sourcefilename);
                    161: 
                    162:     sourcefileopened := false;
                    163:     try
                    164:      S := TFileStream.Create (sourcefilename, fmOpenRead  or fmShareDenyWrite);
                    165:      sourcefileopened := true;
                    166:     except
                    167:      problem := sourcefilename + ' could not be opened';
                    168:     end;
                    169:     if not sourcefileopened then exit;
                    170: 
                    171:     // Dafür sorgen, das vorhandene Datei überschreibbar ist....
                    172:     if FileExists(targetfilename) then
                    173:     begin
                    174:      targetAttr := FileGetAttr(targetfilename);
                    175:      if targetAttr and faReadOnly <> 0 then
                    176:      begin
                    177:       fileresult := FileSetAttr(targetfilename, targetAttr - faReadOnly);
                    178:       if fileresult >0 then
                    179:       begin
                    180:        problem := 'Error: Attribut not set for: '+targetfilename+', error ' + IntToStr (fileresult) ;
                    181:       end;
                    182:      end;
                    183:     end;
                    184: 
                    185:     try
                    186:       T := TFileStream.Create( targetfilename, fmOpenWrite or fmCreate );
                    187: 
                    188:     except
                    189:       S.free;
                    190:       problem := problem + 'Target '+targetfilename+' could not be opened, fileattribute ' + IntToStr (attr);
                    191:       exit;
                    192:     end;
                    193: 
                    194: 
                    195:     try
                    196:       T.CopyFrom(S, S.Size ) ;
                    197: 
                    198:     except
                    199:       T.Free;
                    200:       S.Free;
                    201:       problem := problem + 'Error while copying.';
                    202:       exit;
                    203:     end;
                    204: 
                    205:     T.Free;
                    206:     S.Free;
                    207: 
                    208: 
                    209:     if preserveDate then
                    210:     begin
                    211:      Handle := fileopen (targetfilename, fmOpenWrite + fmShareDenyWrite);
                    212:      fileresult := filesetdate (Handle, Date);
                    213:      if fileresult >0 then
                    214:      begin
                    215:       problem := 'Date not set, error ' + IntToStr (fileresult) ;
                    216:      end;
                    217:      fileclose (handle);
                    218:     end;
                    219: 
                    220:     if preserveAttr then
                    221:     begin
                    222:      fileresult := filesetattr (targetfilename, attr);
                    223:      if fileresult >0 then
                    224:      begin
                    225:       problem := 'Attribut not set, error ' + IntToStr (fileresult) ;
                    226:      end;
                    227:     end;
                    228:     Result := true;
                    229: //    FBar.Gauge1.Progress := FBar.Gauge1.Progress +1;
                    230: //    FBar.Update;
                    231:   End;
                    232: 
                    233: 
                    234: 
                    235: 
                    236: Function FileCheckDate
                    237:          (Const Sourcefilename, Targetfilename: String; OverwriteIfEqual: Boolean) : Boolean;
                    238:  (* Assumption: Both files exist *)
                    239:   Var
                    240:    Handle : Integer;
                    241:    Date1, Date2 : LongInt;
                    242: 
                    243: begin
                    244:   Handle := fileopen (Sourcefilename, fmOpenRead);
                    245:   Date1 := filegetdate (Handle);
                    246:   fileclose (handle);
                    247:   Handle := fileopen (Targetfilename, fmOpenRead);
                    248:   Date2 := filegetdate (Handle);
                    249:   fileclose (handle);
                    250:   if (Date2 < Date1) or ((Date2 = Date1) and OverwriteIfEqual)
                    251:   then
                    252:   Begin
                    253:     Result := true;
                    254:   End
                    255:   else
                    256:   Begin
                    257:     Result := false;
                    258:   End
                    259: end;
                    260: 
                    261: 
                    262: Function AllCopy
                    263: (const SourceMask, Target: String; cpSpecify : TcpSpecify;
                    264:  preserveDate, preserveAttr : boolean;
                    265:  var MainFehler : string): Boolean;
                    266: 
                    267: Var
                    268:   FileFound : Boolean;
                    269:   Recursion_Level : Integer;
                    270:   TeilFehler : string;
                    271: 
                    272: 
                    273:   Procedure AllCopyRecursive
                    274:   (var Recursion_Level : Integer; SourceMask, Target: String;
                    275: //   preserveDate, preserveAttr : boolean;
                    276:    Var FileFound : Boolean; var cpSpecify : TcpSpecify);
                    277: 
                    278:   Var
                    279:     CompleteName, Extension,
                    280:     SourcePath, SourceFilemask, SourceName,
                    281:     TargetPath, TargetFilemask, TargetName: String;
                    282: 
                    283:     FindResultcode: Integer;
                    284:     FileAttr : Integer;
                    285:     SearchResult : TSearchRec;
                    286: 
                    287:     FileFoundOnThisLevel, FileFoundOnADeeperLevel: Boolean;
                    288:     DirectoryExisted : Boolean;
                    289:     DirectoryError : Integer;
                    290: 
                    291: 
                    292:     Procedure ToCopyOrNotToCopy (Const SourceName, TargetName : String);
                    293:     var
                    294:         CopyShallTakePlace : Boolean;
                    295:     Begin
                    296:      if SourceName = TargetName
                    297:      then
                    298:      begin
                    299:      end
                    300:      else
                    301:      begin
                    302:        CopyShallTakePlace := true;
                    303: 
                    304:   (*      if cpSpecify and cpVersionControl = cpVersionControl
                    305:        then
                    306:        Begin
                    307:          Extension := UpperCase (ExtractFileExt (TargetName));
                    308:          delete (Extension, 1, 1);
                    309:          if StrIsIn (Extension, ExtensionsForVersionControl) > 0
                    310:          then
                    311:          CopyShallTakePlace := FileCheckVersions (SourceName, TargetName);
                    312:        End; *)
                    313: 
                    314:        if CopyShallTakePlace and FileExists (TargetName) then
                    315:        begin
                    316:          if cpSpecify and cpNoOverwrite = cpNoOverwrite
                    317:          then
                    318:          Begin
                    319:           CopyShallTakePlace := false;
                    320:          End
                    321:          else if cpSpecify and cpUpdate = cpUpdate
                    322:          then
                    323:          Begin
                    324:            CopyShallTakePlace := FileCheckDate (SourceName, TargetName, false)
                    325:          End
                    326:          else if cpSpecify and cpDateControl = cpDateControl
                    327:          then
                    328:          Begin
                    329:            Extension := UpperCase (ExtractFileExt (TargetName));
                    330:            delete (Extension,1,1);
                    331:            if (Extension = 'EXE')
                    332:            then
                    333:            CopyShallTakePlace := FileCheckDate (SourceName, TargetName, true)
                    334:          End
                    335:          else
                    336:          begin
                    337:          end;
                    338:        End;
                    339: 
                    340:        if CopyShallTakePlace
                    341:        then
                    342:        begin
                    343:          if FileCopy (SourceName, TargetName, preserveDate,
                    344:                       preserveAttr, TeilFehler)
                    345:          then
                    346:          else
                    347:              begin
                    348:                   MainFehler := MainFehler + TeilFehler;
                    349:                   result := false;
                    350:              end;
                    351:        end;
                    352:      end;
                    353:     End;
                    354: 
                    355: 
                    356:   Begin
                    357:     Recursion_Level := Recursion_Level + 1;
                    358:     FileFoundOnThisLevel := false;
                    359: 
                    360:     (* SourceMask auf Standardform bringen *)
                    361: 
                    362:     CompleteName := ExpandFileName (SourceMask);
                    363:     SourcePath := ExtractFilePath (CompleteName);
                    364:     if SourcePath [length (SourcePath)] <> '\' then
                    365:        SourcePath := SourcePath + '\';
                    366:     SourceFilemask := ExtractFileName (CompleteName);
                    367:     if SourceFilemask = '' then SourceFilemask := '*.*';
                    368: 
                    369:     (* TargetMask auf Standardform bringen *)
                    370:     CompleteName := ExpandFileName (Target);
                    371:     TargetPath   := CompleteName;
                    372:     if TargetPath [length (TargetPath)] <> '\' then
                    373:        TargetPath := TargetPath + '\';
                    374: 
                    375: 
                    376:     if (length (TargetPath) > 1) and (TargetPath [length (TargetPath) - 1] = ':')
                    377:     then
                    378:       (* TargetPath is e.g. c:\, that is, not a file but a volume identifier *)
                    379:     else
                    380:     Begin
                    381:       CompleteName := copy (TargetPath, 1, length (TargetPath) - 1);
                    382: 
                    383:       if fileGetAttr (CompleteName) and faDirectory = 0
                    384:       then
                    385:       begin
                    386:         exit;
                    387:       end;
                    388:     End;
                    389: 
                    390:     FindResultcode
                    391:     := FindFirst (SourcePath + SourceFilemask, faAnyfile - faDirectory - faVolumeId,
                    392:                   SearchResult);
                    393: 
                    394:     if FindResultcode = 0
                    395:     then FileFoundOnThisLevel := true
                    396:     else
                    397:     Begin
                    398:     End;
                    399: 
                    400:     while FindResultcode = 0
                    401:     do
                    402:     Begin
                    403:       SourceName := SourcePath + SearchResult.Name;
                    404:       TargetName := TargetPath + SearchResult.Name;
                    405: 
                    406: 
                    407:       ToCopyOrNotToCopy (SourceName, TargetName);
                    408: 
                    409:       FindResultcode := FindNext (SearchResult);
                    410:     end;
                    411: 
                    412:    FindClose (SearchResult);
                    413: 
                    414:    (* Subdirectories im Source-Verzeichnis suchen
                    415:      und gegebenenfalls im Targetverzeichnis neu anlegen *)
                    416: 
                    417:     FindResultcode
                    418:     := FindFirst (SourcePath + '*.*', faDirectory(* faAnyFile *),
                    419:                   SearchResult);
                    420: 
                    421: 
                    422:     while FindResultcode = 0
                    423:     do
                    424:     Begin
                    425:       if (SearchResult.Attr and faDirectory = faDirectory) and
                    426:          (SearchResult.Name <> '.') and
                    427:          (SearchResult.Name <> '..')
                    428:       then
                    429:       Begin
                    430:         DirectoryError := 0;
                    431: 
                    432:         TargetName := TargetPath + SearchResult.Name;
                    433:         FileAttr := FileGetAttr (TargetName);
                    434: 
                    435:         if (FileAttr >= 0)
                    436:         then
                    437:         Begin
                    438: 
                    439:           if FileAttr = faDirectory
                    440:           then
                    441:           Begin
                    442:             DirectoryExisted := true;
                    443:           End
                    444:           else
                    445:           Begin
                    446:             DirectoryError := 1;
                    447:           End
                    448:         end
                    449:         else
                    450:         begin
                    451:           DirectoryExisted := false;
                    452:           try
                    453:             mkdir (TargetName);
                    454:           except
                    455:             DirectoryError := 2;
                    456:           end;
                    457: 
                    458:         end;
                    459: 
                    460:         FileFoundOnADeeperLevel := false;
                    461: 
                    462:         if ((cpSpecify and cpRecursive) = cpRecursive)
                    463:             and (DirectoryError = 0)
                    464:         then
                    465:           (* Rekursion *)
                    466:         Begin
                    467: 
                    468:           AllCopyRecursive
                    469:           (Recursion_Level, SourcePath + SearchResult.Name + '\'+ SourceFileMask,
                    470:            TargetName, FileFoundOnADeeperLevel, cpSpecify);
                    471:           if FileFoundOnADeeperLevel then FileFoundOnThisLevel := true;
                    472: 
                    473:         End;
                    474: 
                    475:         if ((cpSpecify and cpCreateEmptySubdirectories) = 0)
                    476:             and not FileFoundOnADeeperLevel and not DirectoryExisted
                    477:             and (DirectoryError = 0)
                    478:         then
                    479:           (* angelegtes directory wieder entfernen *)
                    480:           rmdir (TargetName);
                    481: 
                    482: 
                    483:       end;
                    484: 
                    485:       FindResultcode := FindNext (SearchResult);
                    486:     end;
                    487: 
                    488:     FindClose (SearchResult);
                    489: 
                    490:     FileFound := FileFoundOnThisLevel (* resp. on a deeper level *);
                    491:     Recursion_Level := Recursion_Level - 1;
                    492:   End;
                    493: 
                    494: Begin
                    495: 
                    496:   result := true;
                    497:   MainFehler := '';
                    498:   TeilFehler := '';
                    499:   FileFound := false;
                    500:   Recursion_Level := -1;
                    501: 
                    502: 
                    503:   AllCopyRecursive
                    504:       (Recursion_Level, SourceMask, Target, FileFound, cpSpecify);
                    505: 
                    506: End;
                    507: 
                    508: 
                    509: 
                    510: function AllDelete(Const Filename : String; recursive, ignoreReadOnly : Boolean; var LastFehler: string):Boolean;
                    511:   Var
                    512:     CompleteName, FileMask : String;
                    513:     DeleteDeeperDir,
                    514:     DeleteStartDir : Boolean;
                    515: 
                    516:   Procedure ExecDelete
                    517:   (Const CompleteName : String; DeleteDir : Boolean);
                    518:   var
                    519:     Filename,
                    520:     FileMask, OrigPath : String;
                    521:     FindResultcode: Integer;
                    522:     SearchResult : TSearchRec;
                    523: 
                    524:     errorNo : Integer;
                    525:     attr : Integer;
                    526: 
                    527:   begin
                    528:           (* Completename zerlegen *)
                    529:     OrigPath := ExtractFilePath (CompleteName);
                    530:     (* endet, wie CompleteName sowohl ursprünglich
                    531:        als auch in der Rekursion konstruiert ist, stets auf \ *)
                    532:     Filemask := ExtractFileName (CompleteName);
                    533: 
                    534:           (* zuerst Subdirectories suchen, so daß per Rekursion die unterste Ebene zuerst gelöscht
                    535:         wird *)
                    536:     if recursive then
                    537:     Begin
                    538:       FindResultcode := FindFirst (OrigPath + '*.*', faDirectory (* faAnyFile *),
                    539:                                    SearchResult);
                    540:       while FindResultcode = 0
                    541:       do
                    542:       Begin
                    543:         if (SearchResult.Attr and faDirectory = faDirectory) and
                    544:            (SearchResult.Name <> '.') and
                    545:            (SearchResult.Name <> '..')
                    546:         then
                    547:            ExecDelete
                    548:            (OrigPath + SearchResult.Name + '\' + FileMask, DeleteDeeperDir);
                    549:         FindResultcode := FindNext (SearchResult);
                    550:       End;
                    551:       sysutils.findclose (SearchResult);
                    552:     End;
                    553: 
                    554:       (* jetzt Suche im Verzeichnis selbst *)
                    555:     if Filemask = ''
                    556:     then
                    557:       Filemask := '*.*';
                    558: 
                    559:     FindResultcode := FindFirst (OrigPath + Filemask, faAnyFile - faDirectory, SearchResult);
                    560: 
                    561:     (* if FindResultcode <> 0
                    562:     then
                    563:     Begin
                    564:       LogS := LogSIndent(LogDatei.LogSIndentLevel  + 1)
                    565:             + 'No file found in ' + OrigPath'
                    566:       LogDatei.DependentAdd (LogS, LevelComplete);
                    567:     End; *)
                    568: 
                    569:     while FindResultcode = 0
                    570:     do
                    571:     Begin
                    572:       Filename := OrigPath + SearchResult.Name;
                    573:       Attr := sysutils.FileGetAttr (Filename);
                    574:       if Attr and faReadOnly = faReadOnly
                    575:       then
                    576:       Begin
                    577:          if ignoreReadOnly
                    578:         then
                    579:         Begin
                    580:           Attr := Attr and (not faReadOnly);
                    581: 
                    582:           ErrorNo := sysutils.FileSetAttr (Filename, Attr);
                    583:           if ErrorNo <> 0 then
                    584:              begin
                    585:                   LastFehler := 'Readonly-Attribut konnte nicht zurückgesetzt werden.';
                    586:                   result := false;
                    587:              end;
                    588:         End
                    589:         else
                    590:         Begin
                    591:           LastFehler := 'Datei konnte nicht gelöscht werden.';
                    592:           result := false;
                    593:         End;
                    594:       End;
                    595: 
                    596:       if Attr and faReadOnly = 0
                    597:       then
                    598:       Begin
                    599:         if sysutils.DeleteFile (OrigPath + SearchResult.Name) = False then
                    600:            begin
                    601:                 LastFehler := 'Datei ' + OrigPath + SearchResult.Name + ' could not be deleted';
                    602:                 result := false;
                    603:            end;
                    604:       End;
                    605: 
                    606:       FindResultcode := FindNext (SearchResult);
                    607:     End;
                    608: 
                    609:     sysutils.findclose (SearchResult);
                    610: 
                    611:     if DeleteDir
                    612:     then
                    613:       (* zum Schluß der Behandlung einer Verzeichnisebene
                    614:          gegebenfalls das Verzeichnis selbst verschwinden lassen *)
                    615:     Begin
                    616:       delete (OrigPath, length (OrigPath), 1);
                    617:       try
                    618:         rmDir (OrigPath);
                    619:       except
                    620:         LastFehler := 'Verzeichnis ' +  OrigPath + ' konnte nicht gelöscht werden.';
                    621:         result := False;
                    622:       end;
                    623:     End;
                    624: 
                    625:   end; (* ExecDelete *)
                    626: 
                    627: 
                    628: Begin
                    629:   result := true;
                    630:   LastFehler := '';
                    631:   (* Filename aufbereiten *)
                    632:   CompleteName := ExpandFileName (Filename);
                    633: 
                    634:        (*  if (FileGetAttr (CompleteName) and faDirectory = faDirectory)
                    635:        funktioniert nicht!! *)
                    636:   if isDirectory (CompleteName)
                    637:   and (CompleteName [length (CompleteName)] <> '\')
                    638:   then
                    639:     CompleteName := CompleteName + '\';
                    640: 
                    641: 
                    642: 
                    643:   Filemask := ExtractFileName (CompleteName);
                    644: 
                    645:   DeleteStartDir := false;
                    646:   DeleteDeeperDir := false;
                    647:   if (Filemask = '') or (Filemask='*.*')
                    648:   then
                    649:     DeleteDeeperDir := true;
                    650:   if Filemask = ''
                    651:   then
                    652:     DeleteStartDir := true;
                    653: 
                    654:   (* Starten *)
                    655:   if isDirectory (ExtractFilePath (CompleteName))
                    656:   then
                    657:     ExecDelete (CompleteName, DeleteStartDir);
                    658: end;
                    659: 
                    660: 
                    661: 
                    662: function ValueOfEnvVar (Const VarName : String) : String;
                    663: 
                    664: {$IFDEF WIN32 }
                    665:    var
                    666:      requiredLength : Integer;
                    667: 
                    668:    function GetEnVar (Const VarName : String; Var Value : String; MaxLength : Integer; Var RequiredLength : Integer) : Integer;
                    669:      (* liefert -1, wenn die Variable nicht gefunden wurde
                    670:         0, wenn MaxLength zu klein für die Aufnahme des Wertes ist
                    671:         1, wenn der Wert erfolgreich bestimmt wurde *)
                    672:    Var
                    673:      lpName : PChar;
                    674:      lpBuffer : PChar;
                    675:      nSize : DWord;
                    676: 
                    677:      ReturnSize : DWord;
                    678: 
                    679:    begin
                    680:     lpName := PChar (Varname);
                    681:     nSize := MaxLength + 1;
                    682:     GetMem (lpBuffer, nSize);
                    683:     ReturnSize := winprocs.GetEnvironmentVariable(lpName, lpBuffer, nSize);
                    684: 
                    685:     if ReturnSize = 0
                    686:     then
                    687:     Begin
                    688:       Value := '/* not found */';
                    689:       requiredLength := 0;
                    690:       result := -1;
                    691:     End
                    692:     else
                    693:     if ReturnSize < nSize
                    694:     then
                    695:     Begin
                    696:       Value := StrPas (lpBuffer);
                    697:       RequiredLength := ReturnSize;
                    698:       result := 1;
                    699:     End
                    700:     else
                    701:     Begin
                    702:       Value :=
                    703:         IntToStr (nSize) + ' /* required ' + IntToStr (ReturnSize) + ' */';
                    704:       RequiredLength := ReturnSize - 1;
                    705:       result := 0;
                    706:     End;
                    707: 
                    708: 
                    709:     FreeMem (lpBuffer);  lpBuffer := nil;
                    710: 
                    711:    end;
                    712: 
                    713:   begin
                    714:     if GetEnVar (VarName, result, 255, RequiredLength) = 1
                    715:     then
                    716:   end;
                    717: 
                    718: {$ELSE }
                    719: 
                    720:   var
                    721:    ptr: PChar;
                    722:    Done: BOOLEAN;
                    723:    found : Boolean;
                    724:    inVarName : Boolean;
                    725:    EnvVar : String;
                    726:   begin
                    727:    ptr :=   GetDOSEnvironment;
                    728:    Done := FALSE;
                    729:    EnvVar := '';
                    730:    result := '';
                    731:    inVarName := true;
                    732:    found := false;
                    733: 
                    734:    WHILE NOT Done and not found DO
                    735:    BEGIN
                    736:      if ptr^ = #0 then
                    737:      Begin
                    738:        if upperCase (EnvVar) = upperCase (VarName)
                    739:        then
                    740:          (* Ende bei gefundenem Wert *)
                    741:          found := true
                    742:        else
                    743:        Begin
                    744:          INC(ptr);
                    745:          if ptr^ = #0
                    746:          then
                    747:            Done := TRUE
                    748:            (* Ende bei nicht gefundenem Wert *)
                    749:          else
                    750:            (* beginne nächste Variable zu rekonstruieren *)
                    751:          Begin
                    752:            inVarName := true;
                    753:            EnvVar := '';
                    754:            result := '';
                    755:            EnvVar := EnvVar + ptr^;
                    756:          End
                    757:        End;
                    758:      End
                    759:      else if ptr^ = '='
                    760:      then
                    761:        inVarName := false
                    762:      else
                    763:        if inVarName
                    764:        then EnvVar := EnvVar + ptr^
                    765:        else result := result + ptr^;
                    766:       INC(ptr);
                    767:    END;
                    768: 
                    769:    if not found then result := '';
                    770: 
                    771:   end;
                    772: {$ENDIF }
                    773: 
                    774:   function PointerAufString (Alpha : String) : PChar;
                    775:   begin
                    776:     {$IFDEF WIN32 }
                    777:       Result := PChar (Alpha);
                    778:     {$ELSE}
                    779:       Result := StrAlloc (length (Alpha) + 1);
                    780:       StrPLCopy (Result, Alpha, length (Alpha));
                    781:     {$ENDIF }
                    782:   end;
                    783: 
                    784: 
                    785:   function FileGetWriteAccess (Const Filename : String; var ActionInfo : String ) : Boolean;
                    786:     var
                    787:     Attr : Integer;
                    788:     ErrorNo : Integer;
                    789:    Begin
                    790:      result := true;
                    791:      ActionInfo := '';
                    792:      if not FileExists (Filename)
                    793:      then exit;
                    794:      Attr := sysutils.FileGetAttr (Filename);
                    795:      if Attr and faReadOnly = faReadOnly
                    796:      then
                    797:      Begin
                    798:        Attr := Attr and (not faReadOnly);
                    799: 
                    800:        ErrorNo := sysutils.FileSetAttr (Filename, Attr);
                    801:        if ErrorNo = 0
                    802:        then
                    803:          ActionInfo := 'Readonly-attribute of file "' + Filename + '" eliminated'
                    804:        else
                    805:        Begin
                    806:          result := false;
                    807:          ActionInfo := 'Readonly-attribute of file "' + Filename + '" could not be eliminated, Code '
                    808:                    + IntToStr (ErrorNo)
                    809:                    {$IFDEF WIN32 }
                    810:                    + ' (' + SysErrorMessage (ErrorNo) + ')'
                    811:                    {$ENDIF WIN32 };
                    812:        End;
                    813:      End;
                    814:    End;
                    815: 
                    816: 
                    817: 
1.3     ! oertel    818: {$ENDIF }
1.1       oertel    819: end.

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