CopyDirEx - Module Crossplattform

Hier könnt Ihr gute, von Euch geschriebene Codes posten. Sie müssen auf jeden Fall funktionieren und sollten möglichst effizient, elegant und beispielhaft oder einfach nur cool sein.
Benutzeravatar
ts-soft
Beiträge: 22292
Registriert: 08.09.2004 00:57
Computerausstattung: Mainboard: MSI 970A-G43
CPU: AMD FX-6300 Six-Core Processor
GraKa: GeForce GTX 750 Ti, 2 GB
Memory: 16 GB DDR3-1600 - Dual Channel
Wohnort: Berlin

CopyDirEx - Module Crossplattform

Beitrag von ts-soft »

Die Funktion dieses Moduls ähnelt dem CopyDirectory() von PB (die ersten 3 Parameter sind gleich),
aber bietet die Möglichkeit einen Fortschritt anzuzeigen, sowie den Abbruch.
Das Kopieren geschieht Rekursiv (hierfür hab ich mir eine Funktion von STARGÅTE ausgeliehen und für meine
Bedürfnisse überarbeitet, danke). Dateiattribute werden autom. wiederhergestellt.

Funktionsweise erschließt sich einem am einfachsten, indem Ihr das eingefügte Beispiel studiert.

Code: Alles auswählen

;======================================================================
; Module:          CopyDirEx.pbi
;
; Author:          Thomas (ts-soft) Schulz
; Date:            Jan 31, 2016
; Version:         1.5
; Target Compiler: PureBasic 5.2+
; Target OS:       All
; License:         Free, unrestricted, no warranty whatsoever
;                  Use at your own risk
;======================================================================
; History:
; Version 1.5
; + small update for windows attributes (special windows 10)

; Version 1.4
; + small update to example

; Version 1.3
; + some optimization
; + more accurate progress

; Version 1.2
; + empty dirs missing, resolved
; + bug with attributes of dirs, resolved

DeclareModule CopyDirEx
  
  EnableExplicit
  
  Prototype.i CopyDirExCB(File.s, Dir.s, Sum.i, Procent.i)
  
  Declare CopyDirectoryEx(SourceDirectory.s,
                          DestinationDirectory.s,
                          Pattern.s = "",
                          BufferSize.l = 4096,
                          CustomEvent.l = #PB_Event_FirstCustomValue, ; This event is fired after Copying finished or canceld (SignalStop).
                          Callback.i = 0)                             ; See Prototype CopyDirExCB.
                                                                      ; Result = Thread (result from CreateThread()).
  Declare SignalStop()                                                ; send a signal to stop copying after actual file!
  
EndDeclareModule

Module CopyDirEx
  
  CompilerIf Not #PB_Compiler_Thread
    CompilerError "CopyDirEx requires ThreadSafe Compileroption!"
  CompilerEndIf
  
  Structure RecursiveFiles
    Directory.s
    Name.s
    Attributes.l
    Date.l[3]
    Size.q
    Type.b
  EndStructure
  
  Structure CopyThreadPara
    SourceDirectory.s
    DestinationDirectory.s
    BufferSize.l
    CustomEvent.l
    Callback.i
    cFiles.i
  EndStructure
  
  Global NewList RecursiveFiles.RecursiveFiles()
  Global Mutex = CreateMutex()
  Global Semaphore = CreateSemaphore()
  Global slash.s
  
  CompilerSelect #PB_Compiler_OS
    CompilerCase #PB_OS_Windows
      slash = "\"
    CompilerDefault
      slash = "/"
  CompilerEndSelect
  
  ; private functions
  CompilerSelect #PB_Compiler_OS
    CompilerCase #PB_OS_Windows
      #FILE_ATTRIBUTE_DEVICE              =     64 ;(0x40)
      #FILE_ATTRIBUTE_INTEGRITY_STREAM    =  32768 ;(0x8000)
      #FILE_ATTRIBUTE_NOT_CONTENT_INDEXED  =   8192;(0x2000)
      #FILE_ATTRIBUTE_NO_SCRUB_DATA        = 131072;(0x20000)
      #FILE_ATTRIBUTE_VIRTUAL              =  65536;(0x10000)
      #FILE_ATTRIBUTE_DONTSETFLAGS = ~(#FILE_ATTRIBUTE_DIRECTORY|
                                       #FILE_ATTRIBUTE_SPARSE_FILE|
                                       #FILE_ATTRIBUTE_OFFLINE|
                                       #FILE_ATTRIBUTE_NOT_CONTENT_INDEXED|
                                       #FILE_ATTRIBUTE_VIRTUAL|
                                       0)
      Macro SetFileAttributesEx(Name, Attribs)
        SetFileAttributes(Name, Attribs & #FILE_ATTRIBUTE_DONTSETFLAGS)
      EndMacro
    CompilerDefault
      Macro SetFileAttributesEx(Name, Attribs)
        SetFileAttributes(Name, Attribs)
      EndMacro
  CompilerEndSelect
  
  Procedure CreateDirectoryEx(DirectoryName.s, FileAttribute = #PB_Default)
    Protected i, c, tmp.s
    
    If Right(DirectoryName, 1) = slash
      DirectoryName = Left(DirectoryName, Len(DirectoryName) -1)
    EndIf
    c = CountString(DirectoryName, slash) + 1
    For i = 1 To c
      tmp + StringField(DirectoryName, i, slash)
      If FileSize(tmp) <> -2
        CreateDirectory(tmp)
      EndIf
      tmp + slash
    Next
    If FileAttribute <> #PB_Default
      SetFileAttributesEx(DirectoryName, FileAttribute)
    EndIf
    If FileSize(DirectoryName) = -2
      ProcedureReturn #True
    EndIf
  EndProcedure
  
  Procedure ExamineRecursiveDirectory(DirectoryName.s, Pattern.s, Directory.s = "")
    Protected Dir, Name.s, n
    Static cFiles.i
    
    If Directory = ""
      ClearList(RecursiveFiles())
      cFiles = 0
    EndIf
    If Right(DirectoryName,1) <> slash : DirectoryName + slash : EndIf
    Dir = ExamineDirectory(#PB_Any, DirectoryName, "")
    If Dir
      While NextDirectoryEntry(Dir)
        Name = DirectoryEntryName(Dir)
        If Name <> ".." And Name <> "."
          If DirectoryEntryType(Dir) = #PB_DirectoryEntry_Directory
            AddElement(RecursiveFiles())
            With RecursiveFiles()
              \Directory = Directory
              \Name = Name
              \Attributes = DirectoryEntryAttributes(Dir)
              For n = 0 To 2
                \Date[n] = DirectoryEntryDate(Dir, n)
              Next n
              \Size = DirectoryEntrySize(Dir)
              \Type = DirectoryEntryType(Dir)
            EndWith
            ExamineRecursiveDirectory(DirectoryName + Name, Pattern, Directory + Name + slash)
          EndIf
        EndIf
      Wend
      FinishDirectory(Dir)
    EndIf
    Dir = ExamineDirectory(#PB_Any, DirectoryName, Pattern)
    If Dir
      While NextDirectoryEntry(Dir)
        Name = DirectoryEntryName(Dir)
        If DirectoryEntryType(Dir) = #PB_DirectoryEntry_File
          AddElement(RecursiveFiles())
          cFiles + 1
          With RecursiveFiles()
            \Directory = Directory
            \Name = Name
            \Attributes = DirectoryEntryAttributes(Dir)
            For n = 0 To 2
              \Date[n] = DirectoryEntryDate(Dir, n)
            Next n
            \Size = DirectoryEntrySize(Dir)
            \Type = DirectoryEntryType(Dir)
          EndWith
        EndIf
      Wend
      FinishDirectory(Dir)
    EndIf
    If Directory = ""
      ResetList(RecursiveFiles())
    EndIf
    ProcedureReturn cFiles
  EndProcedure
  
  Procedure.q CopyFileBuffer(sourceID.i, destID.i, buffersize.i)
    Protected *mem, result.q
    
    *mem = AllocateMemory(buffersize)
    
    If *mem And IsFile(sourceID) And IsFile(destID)
      If Loc(sourceID) + buffersize < Lof(sourceID)
        ReadData(sourceID, *mem, buffersize)
        WriteData(destID, *mem, buffersize)
        result = Loc(destID)
      Else
        buffersize = Lof(sourceID) - Loc(destID)
        If buffersize
          ReadData(sourceID, *mem, buffersize)
          WriteData(destID, *mem, buffersize)
        EndIf
        CloseFile(sourceID)
        CloseFile(destID)
        result = 0
      EndIf
    EndIf
    If MemorySize(*mem) > 0
      FreeMemory(*mem)
    EndIf
    ProcedureReturn result
  EndProcedure
  
  Procedure CopyThread(*ctp.CopyThreadPara)
    Protected sourceID.i, destID.i, bufferSize.l = *ctp\BufferSize, position.q, Size.q, Procent.i, Sum.i, count.i = 0
    Protected CustomEvent.i = *ctp\CustomEvent, DestDir.s = *ctp\DestinationDirectory, SourceDir.s = *ctp\SourceDirectory
    Protected Callback.CopyDirExCB = *ctp\Callback, cFiles = *ctp\cFiles
    
    If Right(DestDir, 1) <> slash : DestDir + slash : EndIf
    If Right(SourceDir, 1) <> slash : SourceDir + slash : EndIf
    
    LockMutex(Mutex)
    
    If ListSize(RecursiveFiles())
      If CreateDirectoryEx(DestDir)
        With RecursiveFiles()
          ForEach RecursiveFiles()
            If TrySemaphore(Semaphore)
              UnlockMutex(Mutex)
              PostEvent(CustomEvent)
              Break
            EndIf
            If \Type = #PB_DirectoryEntry_Directory
              CreateDirectoryEx(DestDir + \Directory + \Name, \Attributes)
              Continue
            Else
              If FileSize(DestDir + \Directory) <> -2
                CreateDirectoryEx(DestDir + \Directory)
              EndIf
              sourceID = ReadFile(#PB_Any, SourceDir + \Directory + \Name)
              If IsFile(sourceID) = #False : count + 1 : Continue : EndIf ; lesen fehlgeschlagen, fortsetzen mit nächstem File.
              FileBuffersSize(sourceID, bufferSize)
              Size = Lof(sourceID)
              destID = CreateFile(#PB_Any, DestDir + \Directory + \Name)
              If IsFile(destID) = #False : CloseFile(sourceID) : count + 1 : Continue : EndIf ; erstellen fehlgeschlagen, fortsetzen mit nächstem File.
              FileBuffersSize(destID, bufferSize)
              Sum = Int((100 * count) / cFiles) + 1
              count + 1
            EndIf
            Repeat
              position = CopyFileBuffer(sourceID, destID, bufferSize)
              Procent = Int((100 * position) / Size) + 1
              
              If position = 0 : Procent = 100 : EndIf
              
              If Callback
                Callback(\Name, \Directory, Sum, Procent)
              EndIf
            Until position = 0
            
            SetFileAttributesEx(DestDir + \Directory + \Name, \Attributes)
            SetFileDate(DestDir + \Directory + \Name, 0, \Date[0])
            SetFileDate(DestDir + \Directory + \Name, 1, \Date[1])
            SetFileDate(DestDir + \Directory + \Name, 2, \Date[2])
            
          Next
          If Callback
            Callback("", "", 100, 100)
          EndIf
        EndWith
      EndIf
    EndIf
    UnlockMutex(Mutex)
    PostEvent(CustomEvent)
  EndProcedure
  
  ; public functions
  Procedure CopyDirectoryEx(SourceDirectory.s, DestinationDirectory.s, Pattern.s = "", BufferSize.l = 4096, CustomEvent.l = #PB_Event_FirstCustomValue, Callback.i = 0)
    Static CopyThreadPara.CopyThreadPara
    Protected Thread, cFiles
    
    If BufferSize = #PB_Default : BufferSize = 4096 : EndIf
    If BufferSize < 1024 : BufferSize = 1024 : EndIf
    
    LockMutex(Mutex)
    cFiles = ExamineRecursiveDirectory(SourceDirectory, Pattern)
    If Not ListSize(RecursiveFiles())
      Debug "ERROR: can't examine SourceDirectory!"
      UnlockMutex(Mutex)
      ProcedureReturn #False
    EndIf
    
    UnlockMutex(Mutex)
    
    With CopyThreadPara
      \SourceDirectory = SourceDirectory
      \DestinationDirectory = DestinationDirectory
      \BufferSize = BufferSize
      \CustomEvent = CustomEvent
      \Callback = Callback
      \cFiles = cFiles
    EndWith
    
    Thread = CreateThread(@CopyThread(), @CopyThreadPara)
    ProcedureReturn Thread
  EndProcedure
  
  Procedure SignalStop()
    SignalSemaphore(Semaphore)
  EndProcedure
EndModule

CompilerIf #PB_Compiler_IsMainFile
  ; example
  
  EnableExplicit
  
  Enumeration #PB_Event_FirstCustomValue
    #ProgressFinish
  EndEnumeration
  
  Global.s DestDir = GetTemporaryDirectory() + "purebasic"
  CompilerSelect #PB_Compiler_OS
    CompilerCase #PB_OS_Windows
      DestDir + "\"
    CompilerDefault
      DestDir + "/"
  CompilerEndSelect
  
  Procedure Callback(File.s, Dir.s, Sum.i, Procent.i)
    Static tmpFile.s
    Static tmpDir.s
    
    If tmpFile <> File And IsGadget(0)
      tmpFile = File
      SetGadgetText(0, "Copy File: " + File)
    EndIf
    If tmpDir <> Dir And IsGadget(1)
      tmpDir = DestDir + Dir
      SetGadgetText(1, "To: " + DestDir + Dir)
    EndIf
    If IsGadget(2)
      SetGadgetState(2, Sum)
    EndIf
    If IsGadget(3)
      SetGadgetState(3, Procent)
    EndIf
  EndProcedure
  
  Procedure OpenProgress()
    OpenWindow(0, 0, 0, 500, 160, "Progress CopyDirEx", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
    TextGadget(0, 10, 10, 480, 30, "")
    TextGadget(1, 10, 40, 480, 30, "")
    ProgressBarGadget(2, 10, 65, 480, 20, 0, 100)
    ProgressBarGadget(3, 10, 95, 480, 20, 0, 100)
    ButtonGadget(4, 150, 125, 160, 30, "cancel")
  EndProcedure
  
  OpenProgress()
  
  Define cancel = #False
  Define Thread = CopyDirEx::CopyDirectoryEx(#PB_Compiler_Home, DestDir, "", 4096, #ProgressFinish, @Callback())
  
  If IsThread(Thread)
    Repeat
      Select WaitWindowEvent()
        Case #PB_Event_CloseWindow
          CopyDirEx::SignalStop()
          HideWindow(0, #True)
          cancel = #True
          
        Case #PB_Event_Gadget
          If EventGadget() = 4 ; cancel
            CopyDirEx::SignalStop()
            cancel = #True
          EndIf
          
        Case #ProgressFinish
          If cancel
            MessageRequester("Progress CopyDirEx", "Copying canceled!")
          Else
            MessageRequester("Progress CopyDirEx", "Copying finished!")
          EndIf
          Break
      EndSelect
    ForEver
  EndIf
CompilerEndIf
Viel Spaß
Thomas
Zuletzt geändert von ts-soft am 31.01.2016 17:13, insgesamt 5-mal geändert.
PureBasic 5.73 LTS | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Nutella hat nur sehr wenig Vitamine. Deswegen muss man davon relativ viel essen.
Bild
Benutzeravatar
ts-soft
Beiträge: 22292
Registriert: 08.09.2004 00:57
Computerausstattung: Mainboard: MSI 970A-G43
CPU: AMD FX-6300 Six-Core Processor
GraKa: GeForce GTX 750 Ti, 2 GB
Memory: 16 GB DDR3-1600 - Dual Channel
Wohnort: Berlin

Re: CopyDirEx - Module Crossplattform

Beitrag von ts-soft »

Update:
History hat geschrieben:; Version 1.2
; + empty dirs missing, resolved
; + bug with attributes of dirs, resolved
History hat geschrieben:; Version 1.3
; + some optimization
; + more accurate progress
PureBasic 5.73 LTS | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Nutella hat nur sehr wenig Vitamine. Deswegen muss man davon relativ viel essen.
Bild
Axolotl
Beiträge: 146
Registriert: 31.12.2008 16:34

Re: CopyDirEx - Module Crossplattform

Beitrag von Axolotl »

Hi Thomas,

SetFileAttributes stürtzt unter windows 10 bei einigen Attributen ab.

Code: Alles auswählen

;'
;' https://msdn.microsoft.com/en-us/library/windows/desktop/gg258117%28v=vs.85%29.aspx
;'
;' Windows only (sorry!)
;'
 #FILE_ATTRIBUTE_DEVICE              =     64 ;(0x40) 
 #FILE_ATTRIBUTE_INTEGRITY_STREAM    =  32768 ;(0x8000)
 #FILE_ATTRIBUTE_NOT_CONTENT_INDEXED  =   8192 ;(0x2000)
 #FILE_ATTRIBUTE_NO_SCRUB_DATA        = 131072 ;(0x20000)
 #FILE_ATTRIBUTE_VIRTUAL              =  65536 ;(0x10000);' 
;#... die anderen gibt es schon.

#FILE_ATTRIBUTE_DONTSETFLAGS = ~(#FILE_ATTRIBUTE_DIRECTORY|
                                 #FILE_ATTRIBUTE_SPARSE_FILE|
                                 #FILE_ATTRIBUTE_OFFLINE|
                                 #FILE_ATTRIBUTE_NOT_CONTENT_INDEXED|
                                 #FILE_ATTRIBUTE_VIRTUAL|
                                 0);
;'-------------------------------
  Macro SetFileAttributesEx(Name, Attribs)
    SetFileAttributes(Name, Attribs&#FILE_ATTRIBUTE_DONTSETFLAGS)
  EndMacro
Wenn man jetzt noch

Code: Alles auswählen

SetFileAttributes 
mit

Code: Alles auswählen

SetFileAttributesEx 
ersetzt, dann gehts (unter Windows)
Gruß Andreas
Mostly running PureBasic <latest stable version and current alpha/beta> (x64) on Windows 11 Home
Benutzeravatar
ts-soft
Beiträge: 22292
Registriert: 08.09.2004 00:57
Computerausstattung: Mainboard: MSI 970A-G43
CPU: AMD FX-6300 Six-Core Processor
GraKa: GeForce GTX 750 Ti, 2 GB
Memory: 16 GB DDR3-1600 - Dual Channel
Wohnort: Berlin

Re: CopyDirEx - Module Crossplattform

Beitrag von ts-soft »

Ja danke, habe obigen Code geupdated!
PureBasic 5.73 LTS | SpiderBasic 2.30 | Windows 10 Pro (x64) | Linux Mint 20.1 (x64)
Nutella hat nur sehr wenig Vitamine. Deswegen muss man davon relativ viel essen.
Bild
Benutzeravatar
Sicro
Beiträge: 955
Registriert: 11.08.2005 19:08
Kontaktdaten:

Re: CopyDirEx - Module Crossplattform

Beitrag von Sicro »

Code im CodeArchiv unter Files_and_Dirs/File/CopyFilesEx.pbi aktualisiert.
Bild
Warum OpenSource eine Lizenz haben sollte :: PB-CodeArchiv-Rebirth :: Pleasant-Dark (Syntax-Farbschema) :: RegEx-Engine (kompiliert RegExes zu NFA/DFA)
Manjaro Xfce x64 (Hauptsystem) :: Windows 10 Home (VirtualBox) :: Neueste PureBasic-Version
Antworten