Gadget-Befehle nicht Threadsafe?
Verfasst: 06.04.2006 13:37
Hallo,
ich habe diese Frage seit geraumer Zeit im englischen Forum, leider (bislang noch) ohne Antwort, deshalb probier ich's auch bei euch...
Hintergrund: die internen Filekopierbefehle lassen sich leider nicht problemlos abbrechen (geöffnete Datei wird gelockt) - ich aber genau das bei einem Kopierprogramm brauche, habe ich es mit folgenden Ansatz probiert
Das klappt eigentlich ganz gut, somit habe ich das ganze nun umgesetzt (siehe die Prozeduren FileCopy, CopyEntry, CopyList und Main)...
Dumm ist leider, dass es NUR funktioniert, wenn ich keine Gadget-Funktionen nutze, sobald eine der ";" (in den Zeilen *** 1 ***,...*** 4 ***) entferne, bleibt das Programm hängen!
Hat jemand einen Tipp?
Zum Austesten müßt ihr...
* ein großes File (SOURCE FILE) und ein Zielverzeichnis (DESTINATION PATH) in der Prozedur Main() angeben
* das Programm mit F5 starten (Optionen threadsafe und debug aktiviert)
* die eingegebene Datei sollte in der Liste sichtbar sein
* den Kopiervorgang mit "S" starten, die Fortschrittsanzeige füllt sich...
* mit "E" das Kopieren beenden (bevor die Fortschrittsanzeige ganz rechts ist)
* wenn alles funktioniert, wird der Start-Knopf wieder enabled und man kann das Programm mit "E" beenden
Wird eine der *** x *** Zeilen aktiviert (linkes ";" entfernen), funktioniert nichts mehr wie vorher - und bleibt hängen!
ich habe diese Frage seit geraumer Zeit im englischen Forum, leider (bislang noch) ohne Antwort, deshalb probier ich's auch bei euch...
Hintergrund: die internen Filekopierbefehle lassen sich leider nicht problemlos abbrechen (geöffnete Datei wird gelockt) - ich aber genau das bei einem Kopierprogramm brauche, habe ich es mit folgenden Ansatz probiert
Code: Alles auswählen
Global abort.l=0
Global count.l=0
Procedure endless()
Repeat
count+1
Debug count
Delay(1)
Until abort;
EndProcedure
Procedure call()
endless()
EndProcedure
thread=CreateThread(@call(),0)
Debug "Wait"
Delay(30)
Debug "Kill"
abort=#True
Debug "killed?"
Delay(50)
Debug "killed!"
Code: Alles auswählen
; Define Version
#version=" CopyMe II V1.3 | (c) 2006 Michael Vogel "
EnableExplicit
; Status
Enumeration
#Idle
#Aborted
#DirCheck
#CopyActive
EndEnumeration
; Gadget-Felder
Enumeration
#textobengadget
#textuntengadget
#updowngadget
#listgadget
#infogadget
#copygadget
#pathgadget
#calcgadget
#cleargadget
#optgadget
#quitgadget
#statusbar
#progressbar
#disablegadget
#optautocheckgadget
#optrecursivegadget
#optautoremovegadget
#optautodeletegadget
#optskingadget
#optfontgadget
#optautocopygadget
#optokgadget
#optframeagadget
#optframebgadget
#optframecgadget
#optframedgadget
;
#keydelete
#keyn
#keyj
EndEnumeration
; Listenspalten
Enumeration
#namecol
#sourcecol
#destcol
#typecol
#sizecol
#copycol
EndEnumeration
; Dateiliste
Structure copyrecord
name.s
sourcepath.s
destpath.s
type.b
size.l
copied.b
EndStructure
#inifile="CopyMe.ini"
#Dateitext="Zu koperierende Dateien in dieses Feld ziehen..."
#statuslen=262
#winlen=420
#max=1000
Global Dim filelist.copyrecord(#max)
Global Status.l=0; kein Status
Global anz.l=-1; Anzahl der Einträge
Global act.l=0; aktuelle Position
Global actpath.s; aktueller Zielpfad
Global copysize.l; Gesamtgröße der zu kopierenden Dateien
Global totalsize.l; Gesamtgröße aller Dateien
Global copyfile.l; Anzahl zu kopierenden Dateien
Global totalfile.l; Anzahl aller Dateien
Global OptAutocheckDir.l=0; Verzeichnisgröße bei Drag and Drop automatisch prüfen
Global OptAutoCopy.l=0; Automatisch kopieren beginnen...
Global OptRecursiveDir.l=0; Verzeichnisse rekursiv kopieren (#PB_FileSystem_Recursive=1)
Global OptAutoRemove.l=0; Kopierte Einträge entfernen...
Global OptAutoDelete.l=0; Kopierte Einträge löschen...
Global OptBigWin.l=1; Großes Fenster bei Programmstart aus
Global OptSmallFont.l=0; kleinere Schriftart
Global OptWinSkin.l=1; Windows-Skinning aktiv
Global DirOptChanged=0; UpdateSizes muß bei 1 ALLE Dateien prüfen...
Global drophandle.l; Handle für Drag and Drop
Global dropcount.l; Zähler für Drag and Drop
Global dropbuffer.s; Puffer für Drag and Drop
#Blocksize=16384
Global *MemBlock=AllocateMemory(#Blocksize)
Global AbortCopy.l=0; this should "kill" the thread...
Global ThreadID.l=0; Thread
Global timer.l; Zähler für Thread-Meldungen
Global ontop.l=0; On-Top Status
Global callback.l=0; Callback-Variable
Global winhandle.l; Fenster-ID
Global disableimage.l;Statusfenster blockieren
Global statusheight.l; Höhe der Statuszeile
Global progress.l; Wert (0-256) des Fortschrittbalkens
Global Wx.l=0; X-Position
Global Wy.l=0; Y-Position
Global Nil.w=0; brauchma...
Global SmallFont=LoadFont(#PB_Any,"Arial",7)
Global Dim CopyText.s(1)
CopyText(0)="nein"
CopyText(1)="ja"
Global Dim CopyColor.l(1)
CopyColor(0)=$60c0ff
CopyColor(1)=$b0ff70
Global Dim TypeText.s(2)
TypeText(0)="-"
TypeText(1)="Verzeichnis"
TypeText(2)="Datei"
; EndDefine
Procedure SetStatus(value.l,text.s="")
Protected update.l=#False
If status<>value Or Len(text)
update=#True
EndIf
timer=0
status=value
If update
Select value
Case #Idle
StatusBarText(#statusbar,0," "+text)
Case #Aborted
If Len(text)
StatusBarText(#statusbar,0," Abbruch - "+text)
Else
StatusBarText(#statusbar,0," Vorgang abgebrochen")
EndIf
Case #DirCheck
StatusBarText(#statusbar,0," Ermittle Größe von "+text)
Case #CopyActive
StatusBarText(#statusbar,0," Kopiere - "+text)
EndSelect
EndIf
EndProcedure
Procedure ClrStatus()
status=#Idle
timer=0
progress=0
StatusBarText(#statusbar,0," Bereit")
SetGadgetState(#progressbar,progress)
DisableGadget(#copygadget,0)
DisableGadget(#calcgadget,0)
EndProcedure
Procedure ListToGadget()
With filelist(anz)
AddGadgetItem(#listgadget, -1,\name+#LF$+\sourcepath+#LF$+\destpath+#LF$+TypeText(\type)+#LF$+Str(\size)+#LF$+CopyText(\copied))
SetGadgetItemColor(#listgadget,anz,#PB_Gadget_BackColor,CopyColor(\copied),5)
totalfile+1
totalsize+\size
If \copied=0
copyfile+1
copysize+\size
EndIf
EndWith
EndProcedure
Procedure.l DragToList(actfile.s)
If anz<#max
Protected i.l=Len(actfile)
; überflüssiges "\" entfernen...
If (i>3) And Right(actfile,1)="\"
i-1
actfile=Left(actfile,i)
EndIf
; fehlendes "\" hinzufügen...
If Right(actpath,1)<>"\"
actpath+"\"
EndIf
; Split nach letztem "\"...
While i
i-1
If PeekB(@actfile+i)='\'
Break
EndIf
Wend
If i
anz+1
With filelist(anz)
\name=Mid(actfile,i+2,#MAXSHORT)
\sourcepath=Left(actfile,i+1)
\destpath=actpath
\copied=0
i=FileSize(actfile)
Select i
Case -2; Verzeichnis [1]
\type=1
;If OptAutocheckDir
; SetStatus(#DirCheck,actfile)
; \size=DirectorySize(1,actfile+"\")>>10+1; in KByte
;Else
\size=0
;EndIf
Case -1; unbekannt [0]
\type=0
\size=0
Default; Datei [2]
\type=2
\size=i>>10+1; in KByte
EndSelect
ListToGadget()
EndWith
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndIf
EndProcedure
; Here's my problem...
Procedure.l FileCopy(von.s,nach.s)
Protected open.l,total.l
Protected soll.l,ist.l
; AbortCopy=1
; ProcedureReturn #False
If FileSize(nach)<>-2; Directory
If ReadFile(1,von)
If CreateFile(2,nach)
total=Lof(1)
open=total
While open>0
If open<1000000
; AbortCopy=1
EndIf
If open>#Blocksize
soll=#Blocksize
Else
soll=open
EndIf
ist=ReadData(1,*MemBlock,soll)
If soll<>ist Or AbortCopy=1
CloseFile(2)
CloseFile(1)
Debug "FileCopy Abort"
ProcedureReturn #False
EndIf
WriteData(2,*MemBlock,ist)
open-ist
SetGadgetState(#progressbar,(total-open)/total>>8)
Delay(1)
Wend
CloseFile(2)
Else
ProcedureReturn #False
EndIf
CloseFile(1)
ProcedureReturn #True
EndIf
EndIf
ProcedureReturn #False
EndProcedure
Procedure.l CopyEntry(nr.l)
Protected ret.l=#True; nicht kopieren ist auch positiv...
With filelist(nr)
Debug \NAME
Debug \copied
Delay(1000)
If \copied=0
ret=#False
If \sourcepath<>\destpath
SetStatus(#CopyActive,\name)
Select \type
Case 2; Datei
;Debug "F:"+\sourcepath+\name+" >> "+\destpath+\name
;If CopyFile(\sourcepath+\name,\destpath+\name)
If FileCopy(\sourcepath+\name,\destpath+\name)
ret=#True
\copied=1
copyfile-1
copysize-\size
Else
Debug "CopyEntry Abort"
Debug AbortCopy
Debug ret
;ProcedureReturn #False
EndIf
Case 1; Verzeichnis
;Debug "D:"+\sourcepath+\name+" >> "+\destpath+\name
If CopyDirectory(\sourcepath+\name,\destpath+\name,"",OptRecursiveDir|#PB_FileSystem_Force)
ret=#True
\copied=1
copyfile-1
copysize-\size
EndIf
EndSelect
EndIf
EndIf
;SetGadgetItemText(#listgadget,nr,CopyText(\copied),#copycol); *** 1 ***
;SetGadgetItemColor(#listgadget,nr,#PB_Gadget_BackColor,CopyColor(\copied),5); *** 2 ***
EndWith
ProcedureReturn ret
EndProcedure
Procedure CopyList(dummy.l)
Protected i.l=-1
DisableGadget(#copygadget,1)
DisableGadget(#calcgadget,1)
If 0; disabled; this would do the full list...
While i<anz And AbortCopy=0
i+1
If CopyEntry(i)
Else
End
If AbortCopy
If OptAutoCopy
SetStatus(#Aborted,"automatisches Kopieren deaktiviert")
OptAutoCopy=#False
Else
SetStatus(#Aborted)
EndIf
Else
SetStatus(#idle,"Kopierfehler - automatisches Kopieren deaktiviert")
OptAutoCopy=#False
EndIf
Beep_(2000,20)
Delay(2000)
Break
EndIf
Wend
;Debug Str(i)+" / "+Str(anz)
ClrStatus()
ThreadID=0
EndIf
; so I'll try it just with one file of the list...
While abortcopy=0
CopyEntry(0)
;StatusBarText(#statusbar,0," Abort="+Str(abortcopy)+", Return="+Str(dummy)); *** 3 ***
Debug AbortCopy
Wend
Debug "CopyList Abort"
;ClrStatus(); *** 4 ***
ThreadID=0
Debug "ok"
EndProcedure
Procedure.s GetDropFile(index.l)
Protected buffersize
Protected buffer.s
buffersize=DragQueryFile_(drophandle,index,0,0)
buffer=Space(buffersize+1)
DragQueryFile_(drophandle, index, @buffer, buffersize+1)
ProcedureReturn buffer
EndProcedure
Procedure Callback(WindowID, Message, wParam, lParam)
Select Message
Case #WM_SYSCOMMAND
If wParam=#SC_MAXIMIZE
Callback=1
ProcedureReturn 0
EndIf
EndSelect
ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure
Procedure InvertGadgetState(g.l)
EndProcedure
Procedure Options()
EndProcedure
Procedure Window()
Protected i.l
Protected lvm.LV_COLUMN
lvm\mask=#LVCF_FMT
lvm\fmt=#LVCFMT_RIGHT
winhandle=OpenWindow(1,0,0,#winlen,392,"CopyMe II",#PB_Window_ScreenCentered|#PB_Window_SystemMenu|#PB_Window_Invisible|#PB_Window_MinimizeGadget|#PB_Window_MaximizeGadget)
If OptWinSkin=0
If OpenLibrary(0,"UxTheme.dll")
Define *getTheme = GetFunction(0,"GetThemeAppProperties")
Define *setTheme = GetFunction(0,"SetThemeAppProperties")
CallFunctionFast(*setTheme,CallFunctionFast(*getTheme)&-4); ~#STAP_ALLOW_NONCLIENT&~#STAP_ALLOW_CONTROLS
SendMessage_(winhandle,#WM_THEMECHANGED,0,0)
CloseLibrary(0)
EndIf
EndIf
If OptSmallFont : SetGadgetFont(#PB_Default,FontID(SmallFont)) :EndIf
CreateGadgetList(winhandle)
TextGadget(#textobengadget,30,12,200,18,"Statistik-Informationen:")
ButtonGadget(#updowngadget,10,10,16,16,"•")
#infolen=222
#infoyps=52
disableimage=CreateImage(0,#infolen,#infoyps)
ImageGadget(#disablegadget,10,31,#infolen,#infoyps,disableimage)
;DisableGadget(#disablegadget,0)
ListIconGadget(#infogadget,10,31,#infolen,#infoyps,"",49,#PB_ListIcon_GridLines)
AddGadgetColumn(#infogadget,1,"offen", 56)
AddGadgetColumn(#infogadget,2,"kopiert", 56)
AddGadgetColumn(#infogadget,3,"Gesamt", 56)
AddGadgetItem(#infogadget,-1,"Dateien")
AddGadgetItem(#infogadget,-1,"MByte")
For i=1 To 3
SendMessage_(GadgetID(#infogadget),#LVM_SETCOLUMN,i,@lvm)
Next i
;DisableGadget(#infogadget,1); jetzt mit "disableimage" realisiert
SetGadgetColor(#infogadget, #PB_Gadget_BackColor,$e8e8e8)
SetGadgetColor(#infogadget, #PB_Gadget_LineColor,$c0c0c0)
GadgetToolTip(#infogadget,#Dateitext)
DragAcceptFiles_(winhandle,1)
#Abutton=242
#Bbutton=329
#Buttonlen=80
ButtonGadget(#copygadget,#Abutton,10,#Buttonlen,22,"")
;GadgetToolTip(#copygadget,"Starten des Kopiervorgangs")
ButtonGadget(#pathgadget,#Bbutton,10,#Buttonlen,22,"&Pfad")
ButtonGadget(#calcgadget,#Abutton,35,#Buttonlen,22,"&Größe")
GadgetToolTip(#calcgadget,"Verzeichnisgrößen prüfen")
ButtonGadget(#cleargadget,#Abutton,60,#Buttonlen,22,"&Löschen")
GadgetToolTip(#cleargadget,"Kopierte Dateien aus Liste entfernen")
ButtonGadget(#optgadget,#Bbutton,35,#Buttonlen,22,"&Optionen")
GadgetToolTip(#optgadget,"Einstellungen")
ButtonGadget(#quitgadget,#Bbutton,60,#Buttonlen,22,"&Ende", #PB_Button_Default)
GadgetToolTip(#quitgadget,"Programm beenden")
TextGadget(#textuntengadget,10,92,200,18,"Dateiliste:")
ListIconGadget(#listgadget, 10,110,400,192,"Name",85,#PB_ListIcon_GridLines|#PB_ListIcon_FullRowSelect|#PB_ListIcon_AlwaysShowSelection)
AddGadgetColumn(#listgadget,#sourcecol,"Quellpfad", 85)
AddGadgetColumn(#listgadget,#destcol,"Zielpfad", 80)
AddGadgetColumn(#listgadget,#typecol,"Typ", 45)
AddGadgetColumn(#listgadget,#sizecol,"Größe (KB)", 66)
AddGadgetColumn(#listgadget,#copycol,"kopiert", 35)
SendMessage_(GadgetID(#listgadget),#LVM_SETCOLUMN,#sizecol,@lvm)
lvm\fmt=#LVCFMT_CENTER
SendMessage_(GadgetID(#listgadget),#LVM_SETCOLUMN,#copycol,@lvm)
GadgetToolTip(#listgadget,#Dateitext)
CreateStatusBar(#statusbar, winhandle)
AddStatusBarField(#statuslen)
statusheight=StatusBarHeight(#statusbar)-2; *** STATUSBAR ***
ProgressBarGadget(#progressbar,0,0,0,0,0,256); Position is set in procedure WinSize()
ClrStatus()
AddKeyboardShortcut(1,#PB_Shortcut_D,#updowngadget)
AddKeyboardShortcut(1,#PB_Shortcut_G,#calcgadget)
AddKeyboardShortcut(1,#PB_Shortcut_O,#optgadget)
AddKeyboardShortcut(1,#PB_Shortcut_L,#cleargadget)
AddKeyboardShortcut(1,#PB_Shortcut_L|#PB_Shortcut_Shift,#cleargadget)
AddKeyboardShortcut(1,#PB_Shortcut_P,#pathgadget)
AddKeyboardShortcut(1,#PB_Shortcut_S,#copygadget)
AddKeyboardShortcut(1,#PB_Shortcut_Escape,#quitgadget)
AddKeyboardShortcut(1,#PB_Shortcut_E,#quitgadget)
AddKeyboardShortcut(1,#PB_Shortcut_Delete,#keydelete)
AddKeyboardShortcut(1,#PB_Shortcut_J,#keyj)
AddKeyboardShortcut(1,#PB_Shortcut_N,#keyn)
SetTimer_(winhandle,1,200,0) ; Default: 100ms
SetWindowCallback(@Callback(),1)
EndProcedure
Procedure UpdateButtonText()
If OptAutoDelete
SetGadgetText(#copygadget,"&Starte...")
GadgetToolTip(#copygadget,"Starten des Verschiebevorgangs")
Else
SetGadgetText(#copygadget,"&Starte")
GadgetToolTip(#copygadget,"Starten des Kopiervorgangs")
EndIf
EndProcedure
Procedure WinSize()
If Wx*Wy
ResizeWindow(1,wx,wy,#PB_Ignore,116+OptBigWin*212)
Wx=0
Wy=0
Else
ResizeWindow(1,#PB_Ignore,#PB_Ignore,#PB_Ignore,116+OptBigWin*212)
EndIf
ResizeGadget(#progressbar,#statuslen+1,116+OptBigWin*212-statusheight,#winlen-#statuslen-2,statusheight); +1 and -2 seems to be fine on my computer, but I don't know how it looks somewhere else...
HideGadget(#textuntengadget,1-OptBigWin)
HideGadget(#listgadget,1-OptBigWin)
EndProcedure
Procedure Main()
Protected quit.l=-1
Protected i.l
Window()
actpath="c:\daten\backup\"; *** DESTINATION PATH ***
DragToList("C:\Dokumente und Einstellungen\vo\Desktop\SPSS\SPSS II.zip"); *** BIG SOURCE FILE ***
GadgetToolTip(#pathgadget,actpath)
WinSize()
UpdateButtonText()
HideWindow(1,0)
Repeat
Select WaitWindowEvent()
Case #PB_Event_Gadget,#PB_Event_Menu
Select EventGadget()
Case #copygadget
If ThreadID=0
ThreadID=CreateThread(@CopyList(),0)
EndIf
Case #optgadget
Options()
UpdateButtonText()
Case #updowngadget
OptBigWin=1-OptBigWin
WinSize()
Case #quitgadget
If ThreadID
AbortCopy=#True
While ThreadID; And IsThread(ThreadID)
Delay(25)
Wend
SetGadgetText(#copygadget,"Bingo")
Beep_(2000,20)
;KillThread(ThreadID)
;ThreadID=0
If status=#CopyActive And OptAutoCopy
SetStatus(#Aborted,"automatisches Kopieren deaktiviert")
OptAutoCopy=#False
Else
SetStatus(#Aborted)
EndIf
ElseIf timer>1;0
quit=999
Else
Beep_(3200,20)
EndIf
EndSelect
Case #PB_Event_CloseWindow
quit=999
Case #WM_TIMER
Select status
Case #Aborted
timer+1
If timer=10
ClrStatus()
EndIf
Case #Idle
timer+1
;SetGadgetText(#textobengadget,Str(timer))
; Auto-Copy...
If OptAutoCopy And copyfile>0 And ThreadID=0
ThreadID=CreateThread(@CopyList(),0)
EndIf
EndSelect
Case #WM_DROPFILES
drophandle=EventwParam()
dropcount=DragQueryFile_(drophandle,$FFFFFFFF,@dropbuffer,0)
i=0
While i<dropcount
DragToList(GetDropFile(i))
i+1
Wend
DragFinish_(drophandle)
Default
If Callback
Callback=0
OnTop=1-OnTop
StickyWindow(1,OnTop)
EndIf
EndSelect
Until quit>0
KillTimer_(winhandle,1)
CloseWindow(1)
FreeMemory(*MemBlock)
EndProcedure
Main()
Dumm ist leider, dass es NUR funktioniert, wenn ich keine Gadget-Funktionen nutze, sobald eine der ";" (in den Zeilen *** 1 ***,...*** 4 ***) entferne, bleibt das Programm hängen!
Hat jemand einen Tipp?
Zum Austesten müßt ihr...
* ein großes File (SOURCE FILE) und ein Zielverzeichnis (DESTINATION PATH) in der Prozedur Main() angeben
* das Programm mit F5 starten (Optionen threadsafe und debug aktiviert)
* die eingegebene Datei sollte in der Liste sichtbar sein
* den Kopiervorgang mit "S" starten, die Fortschrittsanzeige füllt sich...
* mit "E" das Kopieren beenden (bevor die Fortschrittsanzeige ganz rechts ist)
* wenn alles funktioniert, wird der Start-Knopf wieder enabled und man kann das Programm mit "E" beenden
Wird eine der *** x *** Zeilen aktiviert (linkes ";" entfernen), funktioniert nichts mehr wie vorher - und bleibt hängen!