forked from svn2github/freearc
/
ArcCreate.hs
370 lines (330 loc) · 22.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
{-# 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.Exception
import Control.Monad
import Data.IORef
import Data.List
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 ArhiveDirectory
import ArhiveFileList
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 -- íàïå÷àòàòü êàðòó ïàìÿòè
-- äëÿ ñóïåðýêîíîìèè ïàìÿòè: find_files |> buffer 100_000 |> write_to_archive
-- Ñîçäà¸ì sfx-àðõèâ ñðàçó ñ ðàñøèðåíèåì EXE, åñëè òîëüêî ìû íå äîëæíû îáíîâèòü óæå ñóùåñòâóþùèé àðõèâ
arcname <- do archiveExists <- fileExist arcname
if cmd=="create" || not archiveExists
then return$ cmdChangeSfxExt command arcname
else return arcname
command <- return command {cmd_arcname = arcname}
-- Êîìàíäà "create" âñåãäà ñîçäà¸ò àðõèâ ñ íóëÿ
when (cmd=="create")$ 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
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)
-- Íàéòè íà äèñêå äîáàâëÿåìûå àðõèâû (äëÿ êîìàíäû "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 -- Åñëè âûõîäíîé àðõèâ íå ñîäåðæèò íè îäíîãî ôàéëà
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 aMINIMAL_POSSIBLE_DATETIME
let find_last_time dir = last_time .= (\time -> maximum$ time : map (fiTime.fwFileInfo) dir)
let processDir dir = do when (opt_time_to_last command) (find_last_time dir)
postProcess_processDir dir -- âðàïïåð ïîñòïðîöåññèíãà òîæå äîëæåí ïîëó÷èòü ñïèñîê óñïåøíî ñàðõèâèðîâàííûõ ôàéëîâ
-- Ñîîáùèòü ïîëüçîâàòåëþ î íà÷àëå óïàêîâêè äàííûõ
uiStartProcessing (map cfFileInfo files_to_archive) 0 0
performGC -- Ïî÷èñòèòü ìóñîð ÷òîáû îñâîáîäèòü êàê ìîæíî áîëüøå ïàìÿòè äëÿ àëãîðèòìîâ ñæàòèÿ äàííûõ
-- Ñíà÷àëà ìû çàïèñûâàåì ñîäåðæèìîå ñîçäàâàåìîãî àðõèâà âî âðåìåííûé ôàéë è ëèøü çàòåì, ïðè óñïåõå àðõèâàöèè - ïåðåèìåíîâûâàåì åãî
tempfile_wrapper arcname command deleteFiles pretestArchive $ \temp_arcname -> do
ensureCtrlBreak "closeInputArchives" closeInputArchives $ do -- Çàêðîåì âõîäíûå àðõèâû ïî çàâåðøåíèè àðõèâàöèè
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 arcname command -- Ïåðåèìåíóåì àðõèâ, åñëè â íåãî áûë äîáàâëåí èëè èç íåãî óáðàí SFX-ìîäóëü
val results -- Âîçâðàòèì ñòàòèñòèêó âûïîëíåíèÿ êîìàíäû
----------------------------------------------------------------------------------------------------
---- Èñïîëüçîâàíèå âðåìåííîãî ôàéëà ïðè ñîçäàíèè àðõèâà --------------------------------------------
----------------------------------------------------------------------------------------------------
-- |Ïðåôèêñ è ñóôôèêñ èì¸í ñîçäàâàåìûõ âðåìåííûõ ôàéëîâ
temparc_prefix = "$$temparc$$"
temparc_suffix = ".tmp"
-- |Âûïîëíèòü `action` ñ èìåíåì âðåìåííîãî ôàéëà è çàòåì ïåðåèìåíîâàòü åãî
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 <- fileExist tempname
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 -- Ìû âûïîëíÿåì îáíîâëåíèå ñóùåñòâóþùåãî àðõèâà?
handleCtrlBreak "fileRemove tempname" (ignoreErrors$ fileRemove tempname) $ do
-- Âûïîëíèòü àðõèâàöèþ
action tempname
-- Åñëè óêàçàíà îïöèÿ "-t", òî ïðîòåñòèðóåì òîëüêî ÷òî ñîçäàííûé àðõèâ
when (opt_test command) $ do
test_archive tempname (opt_keep_broken command)
handleCtrlBreak "Keeping temporary archive" (condPrintLineLn "n"$ "Keeping temporary archive "++tempname) $ do
-- Óäàëèòü ñàðõèâèðîâàííûå ôàéëû, åñëè èñïîëüçîâàíà îïöèÿ -d
deleteFiles
-- Çàìåíèòü ñòàðûé àðõèâ íîâûì
if old_file
then fileRemove filename -- Õîðîøî áû ïðîâåðÿòü, ÷òî ýòî âñ¸ åù¸ òîò ñàìûé ôàéë
else whenM (fileExist filename) $ do -- Åñëè ôàéë ñ èìåíåì âûõîäíîãî àðõèâà ñîçäàëè çà âðåìÿ àðõèâàöèè, òî ñîîáùèòü îá îøèáêå
registerError$ GENERAL_ERROR ["0312 output archive already exists, keeping temporary file %1", tempname]
fileRename tempname filename
`catch` (\_-> do condPrintLineLn "n"$ "Copying temporary archive "++tempname++" to "++filename
fileCopy tempname filename; fileRemove tempname)
-- Åñëè óêàçàíû îïöèè "-t" è "--create-in-workdir", òî åù¸ ðàç ïðîòåñòèðóåì îêîí÷àòåëüíûé àðõèâ
when (opt_test command && opt_create_in_workdir command) $ do
test_archive filename (opt_keep_broken command || opt_delete_files command /= NO_DELETE)
-- Ïðîòåñòèðîâàòü àðõèâ è âûéòè, óäàëèâ åãî, åñëè ïðè ýòîì âîçíèêëè ïðîáëåìû
test_archive arcname keep_broken_archive = do
w <- count_warnings $ do
testArchive command arcname pretestArchive
-- Ïðîäîëæàòü ðàáîòó òîëüêî ïðè îòñóòñòâèè warning'îâ
when (w/=0) $ do
unless keep_broken_archive (ignoreErrors$ fileRemove arcname)
registerError$ GENERAL_ERROR$ if keep_broken_archive
then ["0313 archive broken, keeping temporary file %1", arcname]
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
-- Ôóíêöèÿ óäàëåíèÿ, ïðè íåîáõîäèìîñòè ñíèìàþùàÿ àòðèáóòû ó ôàéëà
let superRemove removeAction fi = do
let filename = diskName fi
removeAction filename `catch` \e -> do
-- Remove readonly/hidden/system attributes and try to remove file/directory again
ignoreErrors$ clearFileAttributes filename
ignoreErrors$ removeAction filename
-- Óäàëåíèå ôàéëîâ
condPrintLineLn "n"$ "Deleting successfully archived files"
files <- val files2delete
for files $ \fi -> do
whenM (check_that_file_was_not_changed fi) $ do
superRemove fileRemove fi
-- Óäàëåíèå êàòàëîãîâ
when (opt_delete_files command == DEL_FILES_AND_DIRS) $ do
dirs <- val dirs2delete
for (reverse dirs) (superRemove dirRemove) -- Êàòàëîãè îáû÷íî ñîõðàíÿþòñÿ â ïîðÿäêå îáõîäà, òî åñòü ðîäèòåëüñêèé êàòàëîã â ñïèñêå ðàíüøå äî÷åðíèõ. Òàê ÷òî reverse ïîçâîëÿåò óäàëèòü ñíà÷àëà äî÷åðíèå êàòàëîãè
-- Âûïîëíèòü àðõèâàöèþ, çàíîñÿ óñïåøíî ñàðõèâèðîâàííûå ôàéëû â ñïèñêè files2delete è dirs2delete.
-- Óäàëèòü ôàéëû ïîñëå àðõèâàöèè, åñëè çàäàíà îïöèÿ -d[f]
result <- 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 result
-- |Ïðîâåðèòü, ÷òî ôàéë íå èçìåíèëñÿ ñ ìîìåíòà àðõèâàöèè
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 oldArchive = arcArchive old_archive
oldSFXSize = ftSFXSize (arcFooter old_archive)
case sfxname of --  çàâèñèìîñòè îò çíà÷åíèÿ îïöèè "-sfx":
"-" -> return () -- óäàëèòü ñòàðûé sfx-ìîäóëü
"--" -> unless (arcPhantom 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)
changeSfxExt opt_noarcext opt_sfx arcname =
case (opt_noarcext, opt_sfx) of
-- Îòêëþ÷åíî, ïîñêîëüêó ìåøàëî êîíâåðòèðîâàòü â SFX àðõèâû èçíóòðè GUI
-- (True, _) -> arcname -- Íå ìåíÿòü ðàñøèðåíèå, åñëè óêàçàíà îïöèÿ --noarcext
(_ , "--") -> arcname -- èëè íå óêàçàíà îïöèÿ "-sfx"
-- Ïðè "-sfx-" ðàñøèðåíèå ìåíÿåòñÿ íà ".arc"
(_ , "-") -> if takeExtension arcname == aDEFAULT_SFX_EXTENSION
then replaceExtension arcname aDEFAULT_ARC_EXTENSION
else arcname
-- Ïðè "-sfx..." ðàñøèðåíèå ìåíÿåòñÿ íà ".exe"
_ -> if takeExtension arcname == aDEFAULT_ARC_EXTENSION
then replaceExtension arcname aDEFAULT_SFX_EXTENSION
else arcname
-- |Ïåðåèìåíîâàòü àðõèâ â ñîîòâåòñòâèè ñ åãî SFX-èìåíåì
renameArchiveAsSFX arcname command = 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]