-
Notifications
You must be signed in to change notification settings - Fork 1
/
ArcCreate.hs
382 lines (340 loc) · 23.6 KB
/
ArcCreate.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
{-# OPTIONS_GHC -cpp #-}
----------------------------------------------------------------------------------------------------
---- Ñîçäàíèå è èçìåíåíèå àðõèâîâ. ----
---- Çäåñü îòðàáàòûâàþòñÿ âñå êîìàíäû ñîçäàíèÿ è ìîäèôèêàöèè àðõèâîâ: ----
---- create/a/f/m/u/ch/c/d/k/s/rr/j ----
---- Ïðîöåäóðà runArchiveCreate ñîçäà¸ò ñïèñîê ôàéëîâ, êîòîðûå äîëæíû ïîïàñòü â âûõîäíîé àðõèâ, ----
---- çàòåì çàïóñêàåò ïðîöåññû ñîçäàíèÿ ñòðóêòóðû âûõîäíîãî àðõèâà, ÷òåíèÿ âõîäíûõ ôàéëîâ, ----
---- óïàêîâêè è çàïèñè äàííûõ â âûõîäíîé àðõèâ. ----
---- Ýòè ïðîöåññû îïèñàíû â ArcvProcessRead.hs è ArcvProcessCompress.hs ----
----------------------------------------------------------------------------------------------------
module ArcCreate where
import Prelude hiding (catch)
import Control.Concurrent
import Control.OldException
import Control.Monad
import Data.IORef
import Data.List
import Data.Maybe
import System.Mem
import System.IO
#if defined(FREEARC_UNIX)
import System.Posix.Files hiding (fileExist)
#endif
import Utils
import Files
import Charsets (i18n)
import Process
import Errors
import ByteStream
import FileInfo
import Options
import UI
import ArhiveStructure
import ArhiveFileList
import Arhive7zLib
import ArhiveDirectory
import ArcExtract
import ArcvProcessRead
import ArcvProcessExtract
import ArcvProcessCompress
-- |Îáîáù¸ííàÿ êîìàíäà ñîçäàíèÿ/èçìåíåíèÿ àðõèâà
runArchiveCreate pretestArchive
writeRecoveryBlocks
command @ Command { -- äàííûå î âûïîëíÿåìîé êîìàíäå:
cmd_name = cmd -- íàçâàíèå êîìàíäû
, cmd_arcname = arcname -- îñíîâíîé àðõèâ, êîòîðûé ïîäâåðãàåòñÿ îáíîâëåíèþ
, cmd_archive_filter = archive_filter -- ïðåäèêàò âûáîðà îáðàáàòûâàåìûõ ôàéëîâ èç àðõèâîâ
, cmd_added_arcnames = find_added_arcnames -- äîïîëíèòåëüíûå âõîäíûå àðõèâû
, cmd_diskfiles = find_diskfiles -- ôàéëû, êîòîðûå íóæíî äîáàâèòü ñ äèñêà
, opt_arccmt_str = arccmt_str -- íîâûé êîììåíòàðèé ê àðõèâó, èëè
, opt_arccmt_file = arccmt_file -- ôàéë, èç êîòîðîãî ÷èòàåòñÿ íîâûé êîììåíòàðèé ê àðõèâó
, opt_data_compressor = compressor -- àëãîðèòì ñæàòèÿ
} = do
-- Íàïå÷àòàåì êàðòó ïàìÿòè, åñëè âêëþ÷åíà îòëàäêà
opt_testMalloc command &&& testMalloc
-- Ñîçäà¸ì sfx-àðõèâ ñðàçó ñ ðàñøèðåíèåì EXE, åñëè òîëüêî ìû íå äîëæíû îáíîâèòü óæå ñóùåñòâóþùèé àðõèâ
arcname <- do archiveExists <- fileExist arcname
if is_CMD_CREATE cmd || not archiveExists
then return$ cmdChangeSfxExt command arcname
else return arcname
command <- return command {cmd_arcname = arcname}
-- Êîìàíäà "create" âñåãäà ñîçäà¸ò àðõèâ ñ íóëÿ
when (is_CMD_CREATE cmd)$ do ignoreErrors$ fileRemove arcname
-- Ñîîáùèòü ïîëüçîâàòåëþ î íà÷àëå îáðàáîòêè àðõèâà è çàïðîñèòü ïàðîëü àðõèâàöèè, åñëè íåîáõîäèìî
uiStartArchive command =<< limit_compression command compressor -- îãðàíè÷èòü êîìïðåññîð îáú¸ìîì äîñòóïíîé ïàìÿòè è çíà÷åíèåì -lc
command <- (command.$ opt_cook_passwords) command ask_passwords -- ïîäãîòîâèòü ïàðîëè â êîìàíäå ê èñïîëüçîâàíèþ
debugLog "Started"
-- Ïðî÷èòàòü ñëóæåáíóþ èíôîðìàöèþ îñíîâíîãî (îáíîâëÿåìîãî) àðõèâà, âêëþ÷àÿ êàòàëîãè.
-- Âûéòè, åñëè àðõèâ çàëî÷åí èëè ñîäåðæèò recovery info è ïîâðåæä¸í.
-- Åñëè ìû ñîçäà¸ì íîâûé àðõèâ, òî ïîäñòàâèòü âìåñòî ñòàðîãî "ôàíòîì".
let abort_on_locked_archive archive footer = do
-- to do: check that archive type is updatable (f.e. non RAR)
when (ftLocked footer) $
registerError$ GENERAL_ERROR ["0310 can't modify archive locked with -k"]
pretestArchive command archive footer
--
uiStage "0249 Reading archive directory"
updatingArchive <- fileExist arcname
main_archive <- if updatingArchive
then archiveReadInfo command "" "" archive_filter abort_on_locked_archive arcname
else return phantomArc
debugLogList "There are %1 files in archive being updated" (arcDirectory main_archive)
-- Óñòàíîâèòü òèï ñîçäàâàåìîãî àðõèâà
let arctype | isArcPhantom main_archive = opt_archive_type command
| isArcArchive main_archive = aFreeArcInternalExt
| otherwise = arcArchiveType main_archive
command <- return command {opt_archive_type = arctype}
-- Íàéòè íà äèñêå äîáàâëÿåìûå àðõèâû (äëÿ êîìàíäû "j") è ïðî÷èòàòü èõ ñëóæåáíóþ èíôîðìàöèþ.
-- Âûéòè, åñëè ëþáîé èç ýòèõ àðõèâîâ ñîäåðæèò recovery info è ïîâðåæä¸í.
uiStartScanning
added_arcnames <- find_added_arcnames
debugLogList "Found %1 archives to add" added_arcnames
added_archives <- foreach added_arcnames (archiveReadInfo command "" "" archive_filter (pretestArchive command))
debugLogList "There are %1 files in archives to add" (concatMap arcDirectory added_archives)
let input_archives = main_archive:added_archives -- ñïèñîê âñåõ âõîäíûõ àðõèâîâ
closeInputArchives = for input_archives arcClose -- îïåðàöèÿ çàêðûòèÿ âñåõ âõîäíûõ àðõèâîâ
-- Ïîëó÷èòü êîììåíòàðèé ê ñîçäàâàåìîìó àðõèâó ïóò¸ì êîìáèíàöèè ñòàðûõ èëè ââîäîì îò ïîëüçîâàòåëÿ
arcComment <- getArcComment arccmt_str arccmt_file input_archives (opt_parseFile command)
-- Íàéòè äîáàâëÿåìûå ôàéëû íà äèñêå è îòñîðòèðîâàòü èõ ñïèñîê
uiStartScanning
diskfiles <- find_diskfiles
debugLogList "Found %1 files" diskfiles
uiStage "0250 Sorting filelist"
sorted_diskfiles <- (opt_reorder command &&& reorder) (sort_files command diskfiles)
debugLogList "Sorted %1 files" sorted_diskfiles
uiStartScanning -- î÷èñòèì ñ÷¸ò÷èê äëÿ ñòàäèè àíàëèçà ñîäåðæèìîãî ôàéëîâ
-- Ïîëó÷èòü ñïèñîê ôàéëîâ, êîòîðûå äîëæíû ïîïàñòü â âûõîäíîé àðõèâ, ïóò¸ì îáúåäèíåíèÿ.
-- ñïèñêà ôàéëîâ èç îáíîâëÿåìîãî àðõèâà, ñïèñêà ôàéëîâ èç äîáàâëÿåìûõ (êîìàíäîé "j")
-- ê íåìó àðõèâîâ, è ôàéëîâ ñ äèñêà. Ïðåäâàðèòåëüíî ýòè ñïèñêè çà÷èùàþòñÿ îò äóáëèêàòîâ.
files_to_archive <- join_lists main_archive added_archives sorted_diskfiles command
debugLogList "Joined filelists, %1 files" files_to_archive
if null files_to_archive && not (is_CMD_MODIFY cmd) -- Åñëè âûõîäíîé àðõèâ íå ñîäåðæèò íè îäíîãî ôàéëà
then do registerWarning NOFILES -- òî ñîîáùèòü îá ýòîì ïîëüçîâàòåëþ
closeInputArchives -- çàêðûòü âõîäíûå àðõèâû
ignoreErrors$ fileRemove arcname -- óäàëèòü àðõèâ, åñëè îí ñóùåñòâîâàë ïåðåä îïåðàöèåé (íàïðèìåð, â ñëó÷àå êîìàíäû "arc d archive *")
return (1,0,0,0)
else do
-- Âðàïïåð, âûïîëíÿþùèé ïîñòïðîöåññèíã (-d[f], -ac) òîëüêî åñëè ïðè òåñòèðîâàíèè ñîçäàííîãî àðõèâà íå áûëî íè îäíîãî warning'à
postProcess_wrapper command $ \postProcess_processDir deleteFiles -> do
-- Ññûëêà äëÿ âîçâðàòà ðåçóëüòàòîâ ðàáîòû êîìàíäû â âûçûâàþùóþ ïðîöåäóðó
results <- ref (error "runArchiveCreate:results undefined")
-- Ñîõðàíèòü mtime àðõèâà äëÿ îïöèè -tk
old_arc_exist <- fileExist arcname
arc_time <- if old_arc_exist then getFileDateTime arcname else return (error "runArchiveCreate:arc_time undefined")
-- Äëÿ ðåàëèçàöèè îïöèè -tl ìû äîëæíû ïîëó÷àòü ñïèñêè âñåõ çàïèñûâàåìûõ â àðõèâ ôàéëîâ è íàéòè ñàìûé ñâåæèé èç íèõ.
-- Äëÿ ýòîãî â create_archive_structure_PROCESS ïåðåäà¸òñÿ ïðîöåäóðà `find_last_time`.
-- Åé ïåðåäàþò ïî ÷àñòÿì ñïèñîê ôàéëîâ, çàïèñûâàåìûõ â àðõèâ, è îíà îòñëåæèâàåò ñàìûé ñâåæèé èç íèõ.
-- Ýòîé äàòîé áóäåò ïðîøòàìïîâàí àðõèâ ïîñëå îêîí÷àíèÿ àðõèâàöèè.
last_time <- ref aMINIMUM_POSSIBLE_FILETIME
let find_last_time dir = last_time .= (\time -> maximum$ time : map (fiTime.fwFileInfo) dir)
let processDir dir = do when (opt_time_to_last command) $ do
find_last_time dir
postProcess_processDir dir -- âðàïïåð ïîñòïðîöåññèíãà òîæå äîëæåí ïîëó÷èòü ñïèñîê óñïåøíî ñàðõèâèðîâàííûõ ôàéëîâ
-- Ñîîáùèòü ïîëüçîâàòåëþ î íà÷àëå óïàêîâêè äàííûõ
unless (is_CMD_MODIFY$ cmd_name command)$ do
uiStartProcessing (length files_to_archive) (sum$ map (fiSize.cfFileInfo) files_to_archive) 0 0
performGC -- Ïî÷èñòèòü ìóñîð ÷òîáû îñâîáîäèòü êàê ìîæíî áîëüøå ïàìÿòè äëÿ àëãîðèòìîâ ñæàòèÿ äàííûõ
-- Ñíà÷àëà ìû çàïèñûâàåì ñîäåðæèìîå ñîçäàâàåìîãî àðõèâà âî âðåìåííûé ôàéë è ëèøü çàòåì, ïðè óñïåõå àðõèâàöèè - ïåðåèìåíîâûâàåì åãî
tempfile_wrapper arcname command deleteFiles pretestArchive $ \temp_arcname temp_arcnames' -> do
ensureCtrlBreak "closeInputArchives" closeInputArchives $ do -- Çàêðîåì âõîäíûå àðõèâû ïî çàâåðøåíèè àðõèâàöèè
if (arctype /= aFreeArcInternalExt) then szCompress command main_archive arcname temp_arcname temp_arcnames' diskfiles results else do -- Îáðàòèìñÿ ê 7z.dll äëÿ àðõèâàöèè â íåäåôîëòíûé ôîðìàò
bracketCtrlBreak "archiveClose:ArcCreate" (archiveCreateRW temp_arcname) (archiveClose) $ \archive -> do
writeSFX (opt_sfx command) archive main_archive -- Íà÷í¸ì ñîçäàíèå àðõèâà ñ çàïèñè SFX-ìîäóëÿ
-- Ñîçäàíèå àðõèâà - ïîñëåäîâàòåëüíîñòü îòäåëüíûõ ïðîöåññîâ, ïåðåäàþùèõ äàííûå äðóã äðóãó:
-- ïðîöåññà ðàçðàáîòêè ñòðóêòóðû àðõèâà è ÷òåíèÿ óïàêîâûâàåìûõ äàííûõ
-- ïðîöåññà óïàêîâêè è çàïèñè ñæàòûõ äàííûõ â àðõèâíûé ôàéë
-- Ìåæäó íèìè ñîçäà¸òñÿ î÷åðåäü íåîãðàíè÷åííîé äëèíû (|>>>), ÷òî ïîçâîëÿåò îñóùåñòâëÿòü read-ahead ñæèìàåìûõ äàííûõ
let read_files = create_archive_structure_AND_read_files_PROCESS command archive main_archive files_to_archive processDir arcComment writeRecoveryBlocks results
compress_AND_write = compress_AND_write_to_archive_PROCESS archive command
backdoor <- newChan -- Ýòîò êàíàë èñïîëüçóåòñÿ äëÿ âîçâðàùåíèÿ èíôîðìàöèè î ñîçäàííûõ áëîêàõ àðõèâà
runP (read_files backdoor |>>> compress_AND_write backdoor)
--debugLog "Archive written"
when (opt_keep_time command && old_arc_exist) $ do -- Åñëè èñïîëüçîâàíà îïöèÿ -tk è ýòî áûëî îáíîâëåíèå ñóùåñòâóþùåãî àðõèâà
setFileDateTime arcname arc_time -- òî âîññòàíîâèòü mtime àðõèâà
when (opt_time_to_last command) $ do -- Åñëè èñïîëüçîâàíà îïöèÿ -tl
setFileDateTime arcname =<< val last_time -- òî óñòàíîâèòü âðåìÿ&äàòó ìîäèôèêàöèè àðõèâà íà âðåìÿ&äàòó ìîäèôèêàöèè ñàìîãî ñâåæåãî ôàéëà â í¸ì
renameArchiveAsSFX command arcname -- Ïåðåèìåíóåì àðõèâ, åñëè â íåãî áûë äîáàâëåí èëè èç íåãî óáðàí SFX-ìîäóëü
val results -- Âîçâðàòèì ñòàòèñòèêó âûïîëíåíèÿ êîìàíäû
----------------------------------------------------------------------------------------------------
---- Èñïîëüçîâàíèå âðåìåííîãî ôàéëà ïðè ñîçäàíèè àðõèâà --------------------------------------------
----------------------------------------------------------------------------------------------------
-- |Ïðåôèêñ è ñóôôèêñ èì¸í ñîçäàâàåìûõ âðåìåííûõ ôàéëîâ
temparc_prefix = "freearc"
temparc_suffix = ".tmp"
-- |Âûïîëíèòü `action` ñ èìåíåì âðåìåííîãî ôàéëà è çàòåì ïåðåèìåíîâàòü åãî (åñëè íåò îïöèé -v)
tempfile_wrapper filename command deleteFiles pretestArchive action = find 1 >>= doit
where -- Íàéòè ñâîáîäíîå èìÿ äëÿ âðåìåííîãî ôàéëà
find n = do tempdir <- if opt_create_in_workdir command then getTempDir else return (takeDirectory filename)
createDirectoryHierarchy tempdir
let tempname = tempdir </> (temparc_prefix++show n++temparc_suffix)
found <- liftM2 (||) (fileOrDirExist tempname) (fileOrDirExist$ tempname++".001") -- check that both archive and multi-volume archive may be created
case found of
True | n==999 -> registerError$ GENERAL_ERROR ["0311 can't create temporary file"]
| otherwise -> find (n+1)
False -> return tempname
-- Âûïîëíèòü äåéñòâèå, èñïîëüçóÿ âðåìåííîå èìÿ ôàéëà, ïðîòåñòèðîâàòü è çàòåì ïåðåèìåíîâàòü îêîí÷àòåëüíûé àðõèâ
doit tempname = do old_file <- fileExist filename -- Ìû âûïîëíÿåì îáíîâëåíèå ñóùåñòâóþùåãî àðõèâà?
tempnames' <- mvar [tempname]
handleCtrlBreak "fileRemove tempname" (val tempnames' >>= mapM_ (ignoreErrors.fileRemove)) $ do
-- Âûïîëíèòü àðõèâàöèþ
action tempname tempnames'; tempnames <- val tempnames'
-- Åñëè óêàçàíà îïöèÿ "-t", òî ïðîòåñòèðóåì òîëüêî ÷òî ñîçäàííûé àðõèâ
when (opt_test command) $ do
test_archive tempnames (opt_keep_broken command)
-- Ïîëó÷èì èìåíà âðåìåííûõ àðõèâîâ è âû÷èñëèì ñîòâåòñòâóþùèå èì èìåíà îêîí÷àòåëüíûõ ôàéëîâ
tempnames <- val tempnames'
let filenames = tempnames.$map ((filename++) . drop (length$ takeFileName tempname) . takeFileName)
handleCtrlBreak "Keeping temporary archive" (condPrintLineLn "n"$ "Keeping temporary archive "++head tempnames) $ do
-- Óäàëèòü ñàðõèâèðîâàííûå ôàéëû, åñëè èñïîëüçîâàíà îïöèÿ -d
deleteFiles
-- Çàìåíèòü ñòàðûé àðõèâ íîâûì
if old_file && filename==head filenames
then fileRemove filename -- Õîðîøî áû ïðîâåðÿòü, ÷òî ýòî âñ¸ åù¸ òîò ñàìûé ôàéë
else whenM (fileExist filename) $ do -- Åñëè ôàéë ñ èìåíåì âûõîäíîãî àðõèâà ñîçäàëè çà âðåìÿ àðõèâàöèè, òî ñîîáùèòü îá îøèáêå
registerError$ GENERAL_ERROR ["0312 output archive already exists, keeping temporary file %1", head tempnames]
for (zip tempnames filenames) $ \(tempname,filename) -> do
fileRename tempname filename
`catch` (\_-> do condPrintLineLn "n"$ "Copying temporary archive "++tempname++" to "++filename
fileCopy tempname filename; fileRemove tempname)
-- Åñëè óêàçàíà îïöèÿ "-t" è àðõèâû áûëè ñêîïèðîâàíû â äðóãîé êàòàëîã, òî åù¸ ðàç ïðîòåñòèðóåì îêîí÷àòåëüíûé àðõèâ
when (opt_test command && takeDirectory tempname/=takeDirectory filename) $ do
test_archive filenames (opt_keep_broken command || opt_delete_files command /= NO_DELETE)
-- Ïðîòåñòèðîâàòü àðõèâ è âûéòè, óäàëèâ åãî, åñëè ïðè ýòîì âîçíèêëè ïðîáëåìû
test_archive arcnames keep_broken_archive = do
w <- count_warnings $ do
testArchive command (head arcnames) pretestArchive
-- Ïðîäîëæàòü ðàáîòó òîëüêî ïðè îòñóòñòâèè warning'îâ
when (w/=0) $ do
unless keep_broken_archive $ do
for arcnames (ignoreErrors.fileRemove)
registerError$ GENERAL_ERROR$ if keep_broken_archive
then ["0313 archive broken, keeping temporary file %1", head arcnames]
else ["0314 archive broken, deleting"]
----------------------------------------------------------------------------------------------------
---- Ïîñòïðîöåññèíã, âûïîëíÿåìûé òîëüêî åñëè àðõèâàöèÿ ïðîøëà óñïåøíî ------------------------------
----------------------------------------------------------------------------------------------------
-- |Ïîñòïðîöåññèíã, âûïîëíÿåìûé òîëüêî åñëè àðõèâàöèÿ ïðîøëà óñïåøíî:
-- óäàëèòü óñïåøíî ñàðõèâèðîâàííûå ôàéëû, åñëè çàäàíà îïöèÿ -d[f]
-- ñáðîñèòü ó íèõ àòðèáóòû Archive, åñëè çàäàíà îïöèÿ -ac
postProcess_wrapper command archiving = do
doFinally uiDoneArchive2 $ do
case (opt_delete_files command/=NO_DELETE || opt_clear_archive_bit command) of
False -> archiving (\dir->return()) (return()) -- Åñëè ôàéëû óäàëÿòü íå íóæíî, òî ïðîñòî âûïîëíèì archiving
_ -> do files2delete <- ref [] -- Ñïèñîê ôàéëîâ, êîòîðûå ìû äîëæíû óäàëèòü
dirs2delete <- ref [] -- Ñïèñîê êàòàëîãîâ, êîòîðûå ìû äîëæíû óäàëèòü
let -- Ýòîé ïðîöåäóðå ïî ÷àñòÿì ïåðåäà¸òñÿ ñïèñîê óñïåøíî ñàðõèâèðîâàííûõ ôàéëîâ è êàòàëîãîâ,
-- è îíà çàïîìèíàåò èõ âñå ñ òåì, ÷òîáû ïîñëå óñïåøíîãî îêîí÷àíèÿ àðõèâàöèè óäàëèòü èõ
processDir filelist0 = do
let filelist = map fwFileInfo$ filter isFILE_ON_DISK filelist0
(dirs,files) = partition fiIsDir filelist
evalList files `seq` (files2delete ++= files)
evalList dirs `seq` (dirs2delete ++= dirs )
-- Óäàëèòü ñàðõèâèðîâàííûå ôàéëû è êàòàëîãè
deleteFiles = when (opt_delete_files command /= NO_DELETE) $ do
condPrintLineLn "n"$ "Deleting successfully archived files"
-- Óäàëåíèå ôàéëîâ
files <- val files2delete
for files $ \fi -> do
whenM (check_that_file_was_not_changed fi) $ do
forcedFileRemove (diskName fi)
-- Óäàëåíèå êàòàëîãîâ
when (opt_delete_files command == DEL_FILES_AND_DIRS) $ do
dirs <- val dirs2delete
for (reverse dirs) (dirRemove.diskName) -- Êàòàëîãè îáû÷íî ñîõðàíÿþòñÿ â ïîðÿäêå îáõîäà, òî åñòü ðîäèòåëüñêèé êàòàëîã â ñïèñêå ðàíüøå äî÷åðíèõ. Òàê ÷òî reverse ïîçâîëÿåò óäàëèòü ñíà÷àëà äî÷åðíèå êàòàëîãè
-- Âûïîëíèòü àðõèâàöèþ, çàíîñÿ óñïåøíî ñàðõèâèðîâàííûå ôàéëû â ñïèñêè files2delete è dirs2delete.
-- Óäàëèòü ôàéëû ïîñëå àðõèâàöèè, åñëè çàäàíà îïöèÿ -d[f]
results <- archiving processDir deleteFiles
-- Ñáðîñèòü àòðèáóò "àðõèâèðîâàíî" ó óñïåøíî óïàêîâàííûõ ôàéëîâ, åñëè çàäàíà îïöèÿ -ac
when (opt_clear_archive_bit command) $ do
condPrintLineLn "n"$ "Clearing Archive attribute of successfully archived files"
files <- val files2delete
for files $ \fi -> do
whenM (check_that_file_was_not_changed fi) $ do
clearArchiveBit.fpFullname.fiDiskName$ fi
return results
-- |Ïðîâåðèòü, ÷òî ôàéë íå èçìåíèëñÿ ñ ìîìåíòà àðõèâàöèè
check_that_file_was_not_changed fi = do
fileWithStatus "check_that_file_was_not_changed" (fpFullname.fiDiskName$ fi) $ \p_stat -> do
size <- stat_size p_stat
time <- stat_mtime p_stat
return (size==fiSize fi && time==fiTime fi)
----------------------------------------------------------------------------------------------------
---- Âñïîìîãàòåëüíûå îïåðàöèè ----------------------------------------------------------------------
----------------------------------------------------------------------------------------------------
-- |Ïîëó÷èòü êîììåíòàðèé âûõîäíîãî àðõèâà èç ôàéëà, óêàçàííîãî îïöèåé -z,
-- èëè êîíêàòåíàöèåé êîììåíòàðèåâ âõîäíûõ àðõèâîâ, è âûâåñòè åãî íà ýêðàí
getArcComment arccmt_str arccmt_file input_archives parseFile = do
-- Èñïîëüçóåì êîììåíòàðèé, çàäàííûé â êîìàíäíîé ñòðîêå, åñëè åñòü
if arccmt_str>"" then do uiPrintArcComment arccmt_str
return arccmt_str
else do
let old_comment = joinWith "\n\n" $ deleteIf null $ map arcComment input_archives
--  çàâèñèìîñòè îò çíà÷åíèÿ îïöèè "-z":
case arccmt_file of
-- Ââåñòè êîììåíòàðèé ñ stdin
"" -> uiInputArcComment old_comment
-- Óäàëèòü ñòàðûé êîììåíòàðèé
"-" -> return ""
-- Ñêîïèðîâàòü ñóùåñòâóþùèé êîììåíòàðèé (ïî óìîë÷àíèþ):
"--" -> do uiPrintArcComment old_comment
return old_comment
-- Ïðî÷èòàòü íîâûé êîììåíòàðèé èç óêàçàííîãî ôàéëà:
_ -> do newcmt <- parseFile 'c' arccmt_file >>== joinWith "\n"
uiPrintArcComment newcmt
return newcmt
-- |Çàïèñàòü SFX-ìîäóëü â íà÷àëî ñîçäàâàåìîãî àðõèâà
writeSFX sfxname archive old_archive = do
let Just oldArchive = arcArchive old_archive
oldSFXSize = ftSFXSize (arcFooter old_archive)
case sfxname of --  çàâèñèìîñòè îò çíà÷åíèÿ îïöèè "-sfx":
"-" -> return () -- óäàëèòü ñòàðûé sfx-ìîäóëü
"--" -> unless (isArcPhantom old_archive) $ do -- ñêîïèðîâàòü sfx èç èñõîäíîãî àðõèâà (ïî óìîë÷àíèþ)
archiveCopyData oldArchive 0 oldSFXSize archive
filename -> bracket (archiveOpen sfxname -- ïðî÷èòàòü ìîäóëü sfx èç óêàçàííîãî ôàéëà
`catch` (\e -> registerError$ GENERAL_ERROR ["0315 can't open SFX module %1", sfxname]))
(archiveClose)
(\sfxfile -> do size <- archiveGetSize sfxfile
archiveCopyData sfxfile 0 size archive)
-- |Íîâîå èìÿ àðõèâà â ñîîòâåòñòâèè ñ òåì, ÷òî ìû äîáàâèëè èëè íàîáîðîò óáðàëè èç íåãî SFX-ìîäóëü
cmdChangeSfxExt command = changeSfxExt (opt_noarcext command) (opt_sfx command) (opt_archive_type command)
changeSfxExt opt_noarcext opt_sfx arctype arcname =
case (opt_noarcext, opt_sfx) of
-- Îòêëþ÷åíî, ïîñêîëüêó ìåøàëî êîíâåðòèðîâàòü â SFX àðõèâû èçíóòðè GUI
-- (True, _) -> arcname -- Íå ìåíÿòü ðàñøèðåíèå, åñëè óêàçàíà îïöèÿ --noarcext
(_ , "--") -> arcname -- èëè íå óêàçàíà îïöèÿ "-sfx"
-- Ïðè "-sfx-" ðàñøèðåíèå ìåíÿåòñÿ íà ".arc/.7z"
(_ , "-") -> if takeExtension arcname == aDEFAULT_SFX_EXTENSION
then replaceExtension arcname ("."++arctype)
else arcname
-- Ïðè "-sfx..." ðàñøèðåíèå ìåíÿåòñÿ íà ".exe"
_ -> if takeExtension arcname == "."++arctype
then replaceExtension arcname aDEFAULT_SFX_EXTENSION
else arcname
-- |Ïåðåèìåíîâàòü àðõèâ â ñîîòâåòñòâèè ñ åãî SFX-èìåíåì
renameArchiveAsSFX command arcname = do
let newname = cmdChangeSfxExt command arcname
when (newname/=arcname) $ do
condPrintLineLn "n"$ "Renaming "++arcname++" to "++newname
fileRename arcname newname
#if defined(FREEARC_UNIX)
-- Äîáàâèòü èëè óáðàòü "+x" èç àòðèáóòîâ ôàéëà, åñëè åãî sfx-ïðåôèêñ èçìåíèëñÿ
when (opt_sfx command /= "--") $ do
let isSFX = opt_sfx command /= "-"
oldmode <- fmap fileMode (fileGetStatus newname)
let newmode = foldl (iif isSFX unionFileModes removeFileModes) oldmode executeModes
fileSetMode newname newmode
#endif
-- |Ïðîòåñòèðîâàòü òîëüêî ÷òî ñîçäàííûé àðõèâ, íàõîäÿùèéñÿ â ôàéëå ïî èìåíè `temp_arcname`
testArchive command temp_arcname pretestArchive = do
let test_command = command{ cmd_name = "t" -- Òåñòèðóåì
, cmd_arcname = temp_arcname -- â ñîçäàííîì àðõèâå
, opt_arc_basedir = "" -- âñå ôàéëû
, opt_disk_basedir = "" -- ...
, cmd_archive_filter = const True -- ...
, cmd_subcommand = True -- Ýòî ïîäêîìàíäà (òåñòèðîâàíèå âíóòðè óïàêîâêè)
, opt_pretest = 1 -- íå ñòîèò ïðîâîäèòü òåñòèðîâàíèå ïåðåä òåñòèðîâàíèåì, íî recovery info ïðîâåðèòü íàäî :)
}
uiStartSubCommand command test_command
results <- runArchiveExtract pretestArchive test_command
uiDoneSubCommand command test_command [results]