-
Notifications
You must be signed in to change notification settings - Fork 2
/
Copy pathCmdline.hs
874 lines (770 loc) · 52.9 KB
/
Cmdline.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
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
{-# OPTIONS_GHC -cpp #-}
---------------------------------------------------------------------------------------------------
---- Ïðåâðàùåíèå êîìàíäíîé ñòðîêè â íàáîð êîìàíä/îïöèé íà âûïîëíåíèå. ----
---------------------------------------------------------------------------------------------------
module Cmdline where
import Prelude hiding (catch)
import Control.OldException
import Control.Monad
import Control.Concurrent
import Data.Array
import Data.Bits
import Data.Char
import Data.IORef
import Data.List
import Data.Maybe
import Foreign.C
import Foreign.C.Types
import System.Environment
import System.IO.Unsafe
import System.Time
import qualified CompressionLib
import Utils
import Files
import Charsets
import Errors
import FileInfo
import Compression
import Arhive7zLib
import Options
#if defined(FREEARC_WIN)
import System.Win32.File (fILE_ATTRIBUTE_ARCHIVE)
#endif
-- |Ðàçáèðàåò êîìàíäíóþ ñòðîêó è âîçâðàùàåò ñïèñîê çàäàííûõ â íåé êîìàíä â âèäå ñòðóêòóð Command.
-- Êàæäàÿ êîìàíäà ñîäåðæèò èìÿ êîìàíäû, ñïåöèôèêàöèþ àðõèâîâ, ñïèñîê ñïåöèôèêàöèé ôàéëîâ è îïöèè.
-- Êîìàíäû ðàçäåëÿþòñÿ " ; ", íàïðèìåð "a archive -r ; t archive ; x archive"
parseCmdline cmdline = (`mapMaybeM` split ";" cmdline) $ \args -> do
-- Óñòàíîâèòü display_option â çíà÷åíèå ïî óìîë÷àíèþ, ïîñêîëüêó äðóãîãî ñëó÷àÿ ìîæåò íå ïðåäñòàâèòüñÿ.
display_option' =: aDISPLAY_DEFAULT
let options = takeWhile (/="--") $ filter (match "-*") args
-- Åñëè êîìàíäíàÿ ñòðîêà íå ñîäåðæèò íè÷åãî êðîìå îïöèé - íàïå÷àòàòü help/êîíôèãóðàöèþ è âûéòè
if args==options then do
putStr $ if options `contains` "--print-config"
then unlines ("":";You can insert these lines into ARC.INI":aCOMPRESSION_METHODS:builtinMethodSubsts)
else aHELP
return Nothing
else do
-- Additional filters for params of some options when required to resolve ambiguity
let option_checks = [("type", (\arctype -> (arctype `elem` ["--",aFreeArcExt]) || (arctype/="" && szCheckType arctype)))]
-- Ïðî÷èòàåì îïöèè èç ïåðåìåííîé ñðåäû FREEARC èëè çàäàííîé â îïöèè -env
(o0, _) <- parseOptions options option_checks [] []
let no_configs = findReqList o0 "config" `contains` "-"
env_options <- case (findReqArg o0 "env" "--") of
"--" | no_configs -> return "" -- Îïöèÿ -cfg- â êîìàíäíîé ñòðîêå îòêëþ÷àåò èñïîëüçîâàíèå È arc.ini, È %FREEARC
| otherwise -> getEnv aCONFIG_ENV_VAR `catch` (\e -> return "")
"-" -> return ""
env -> getEnv env
-----------------------------------------------------------------------------------------------------------
-- ÐÀÇÁÎÐ ÊÎÍÔÈÃ-ÔÀÉËÀ ------------------------------------------------------------------------------------
-----------------------------------------------------------------------------------------------------------
-- Ïðî÷èòàåì êîíôèã-ôàéëû arc*.ini èëè óêàçàííûå îïöèåé -cfg
(o1, _) <- parseOptions (words env_options++options) option_checks [] [] -- îïöèÿ -cfg ìîæåò áûòü çàäàíà â êîìàíäíîé ñòðîêå èëè â ïåðåìåííîé ñðåäû
cfgfiles <- case (findReqArg o1 "config" "--") of
"-" -> return []
"--" -> findFiles configFilePlaces aCONFIG_FILES
cfg -> findFiles configFilePlaces cfg
-- Îáðàáîòàåì îïöèþ --charset/-sc, ÷òîáû îïðåäåëèòü êîäèðîâêó äëÿ ÷òåíèÿ êîíôèã-ôàéëîâ
let (_, parseFile1, _, _, _) = parse_charset_option (findReqList o1 "charset")
-- Ïðî÷èòàåì ñîäåðæèìîå êîíôèã-ôàéëîâ, è óäàëèì èç íèõ ïóñòûå ñòðîêè è êîììåíòàðèè
configs <- foreach cfgfiles $ \cfgfile -> do
config <- parseFile1 'i' cfgfile >>== map trim >>== deleteIfs [null, match ";*"]
-- Ðàçîáü¸ì êîíôèã íà äâå ÷àñòè - îïöèè ïî óìîë÷àíèþ èç ïåðâîé ñòðîêè è ñåêöèè êîíôèãóðàöèè
return$ case config of
x:xs | not (isSectionHeading x) -> (x, xs)
_ -> ("", config)
-- Ñîáðåð¸ì èíôîðìàöèþ èç âñåõ êîíôèã-ôàéëîâ
let config_1st_line = unwords (map fst configs)
config_remainder = concatMap snd configs
-- Ýòè îïðåäåëåíèÿ ïðåâðàùàþò ñîäåðæèìîå êîíôèã-ôàéëîâ â íàáîð ñåêöèé, òåêñò êîòîðûõ ìîæåò áûòü çàïðîøåí ôóíêöèåé configSection.
-- Ê ïðèìåðó, configSection "[Compression methods]" - ñïèñîê ñòðîê â ñåêöèÿõ "[Compression methods]"
let (externalSections, otherSections) = partition (match aEXTERNAL_COMPRESSOR.head) $ makeGroups isSectionHeading config_remainder
joinedSections = otherSections .$ map makeSection .$ groupFst .$ mapSnds concat -- ñëèòü îäíîèì¸ííûå ñåêöè èç ðàçíûõ êîíôèã-ôàéëîâ
configSection name = lookup (cleanupSectionName name) joinedSections `defaultVal` []
makeSection (x:xs) = (cleanupSectionName x, xs)
-- Äåêîäèðîâàòü ìåòîä ñæàòèÿ/äîï. àëãîðèòìû, èñïîëüçóÿ íàñòðîéêè èç ñåêöèè "[Compression methods]"
decode_compression_method cpus = decode_method cpus (configSection aCOMPRESSION_METHODS)
decode_method_sequence cpus = snd . head . decode_compression_method cpus
-- À ýòè îïðåäåëåíèÿ ïîçâîëÿþò âûòàùèòü èç ñåêöèè ýëåìåíò ñ çàäàííûì èìåíåì,
-- âêëþ÷àÿ ñëó÷àè, êîãäà ëåâàÿ ñòîðîíà îïðåäåëåíèÿ ñîäåðæèò íåñêîëüêî ñëîâ,
-- êîòîðûì äà¸òñÿ îäíî è òî æå îïðåäåëåíèå,
-- è êîãäà îïðåäåëåíèå ïîâòîðÿåòñÿ (â ýòîì ñëó÷àå íàäî ñëèòü âñå ñòðîêè).
-- Ïðèìåð:
-- a create j = -m4x -ms
-- a = --display
--  ýòîì ñëó÷àå (configElement section "a") âîçâðàòèò "-m4x -ms --display"
let sectionElement name = unwords . map snd
. filter (strLowerEq name . fst)
. concatMap (\line -> let (a,b) = split2 '=' line
in map (\w->(w,trim b)) (words$ trim a))
configElement section element = configSection section .$ sectionElement element
-- Èìÿ êîìàíäû: "a", "create" è òàê äàëåå. Îïöèè ïî óìîë÷àíèþ äëÿ ýòîé êîìàíäû, çàäàííûå â êîíôèã-ôàéëå
let cmd = head1$ filter (not.match "-*") args
default_cmd_options = configElement aDEFAULT_OPTIONS cmd
-----------------------------------------------------------------------------------------------------------
-----------------------------------------------------------------------------------------------------------
-- Íàñòðîéêè, ñäåëàííûå â GUI Settings dialog
gui_options <- not no_configs &&& readGuiOptions
-- Äîáàâèì â íà÷àëî êîìàíäíîé ñòðîêè îïöèè ïî óìîë÷àíèþ äëÿ âñåõ êîìàíä, îïöèè èç freearc.ini (â GUI-âåðñèè),
-- îïöèè ïî óìîë÷àíèþ äëÿ ýòîé êîìàíäû è ñîäåðæèìîå ïåðåìåííîé ñðåäû
let additional_args = words config_1st_line ++ gui_options ++ words default_cmd_options ++ words env_options
-- Ðàçáåð¸ì êîìàíäíóþ ñòðîêó, ïîëó÷èâ íàáîð îïöèé è ñïèñîê "ñâîáîäíûõ àðãóìåíòîâ"
(o, freeArgs) <- parseOptions (additional_args++args) option_checks [] []
-- Ñîîáùèòü îá îøèáêå, åñëè "ñâîáîäíûõ àðãóìåíòîâ" ìåíüøå äâóõ - îòñóòñòâóåò êîìàíäà èëè èìÿ àðõèâà
case freeArgs of
[] -> registerError$ CMDLINE_NO_COMMAND args
[cmd] -> registerError$ CMDLINE_NO_ARCSPEC args
otherwise -> return ()
let (cmd:pure_arcspec:pure_filespecs) = freeArgs
-- Àðãóìåíòû: íàçâàíèå îïöèè è çíà÷åíèå ïî óìîë÷àíèþ
let grouping = findReqArg o "solid" aDEFAULT_DATA_GROUPING .$ parseSolidOption
group_dir = fst3 grouping
group_data = snd3 grouping
defaultDirCompressor = thd3 grouping ||| aDEFAULT_DIR_COMPRESSION
orig_dir_compressor = findReqArg o "dirmethod" defaultDirCompressor .$ decode_compression_method 1
compression_options = findReqList o "method"
orig_sort_order = findMaybeArg o "sort"
yes = findNoArg o "yes"
autogenerate_arcname = findOptArg o "autogenerate" "--" ||| "%Y%m%d%H%M%S"
indicator = findOptArg o "indicator" "1" ||| "0" -- ïî óìîë÷àíèþ -i1; -i ýêâèâàëåíòíî -i0
recovery = findOptArg o "recovery" (if take 2 cmd=="rr" then drop 2 cmd else "--") -- êîìàíäà "rr..." ýêâèâàëåíòíà êîìàíäå "ch -rr..."
.$ changeTo [("0.1%","0*4kb"), ("0.01%","0*64kb")]
orig_workdir = findOptArg o "workdir" "" .$ changeTo [("--","")]
create_in_workdir = findNoArg o "create-in-workdir"
pretest = findOptArg o "pretest" "1" .$ changeTo [("-","0"), ("+","2"), ("","2")]
broken_archive = findReqArg o "BrokenArchive" "-" ||| "0"
language = findReqArg o "language" "--"
pause_before_exit = findOptArg o "pause-before-exit" "--" .$changeTo [("--",iif isGUI (iif (cmd=="t" || test_opt) "on" "on-warnings") "off"), ("","on"), ("yes","on"), ("no","off"), ("always","on"), ("never","off")]
shutdown = findNoArg o "shutdown"
noarcext = findNoArg o "noarcext"
crconly = findNoArg o "crconly"
nodata = findNoArg o "nodata"
url_proxy = findOptArg o "proxy" "--"
url_bypass = findOptArg o "bypass" ""
exclude_path = findOptArg o "ExcludePath" "--"
global_queueing_opt = findNoArg o "queue"
test_opt = findNoArg o "test"
-- In absence of -tTYPE option, type of new archives is defined by the arcspec extension: "a a.zip" is the same as "a a.zip -tzip"
default_arctype = szFindFormatForArchiveName pure_arcspec ||| aFreeArcExt
archive_type = findReqArg o "type" "--" .$ changeTo [("--", default_arctype)]
archive_extension = if archive_type==aFreeArcInternalExt then aDEFAULT_ARC_EXTENSION else szDefaultExtension archive_type
add_exclude_path = exclude_path .$ changeTo [("--", "9"), ("", "0")] .$ readInt
dir_exclude_path = if cmd=="e" then 0
else if cmdType cmd==EXTRACT_CMD then add_exclude_path
else 3
-- Ñïèñîê äåéñòâèé, êîòîðûå íàäî âûïîëíèòü íåïîñðåäñòâåííî ïåðåä íà÷àëîì âûïîëíåíèÿ êîìàíäû
setup_command <- newList
let setup action = do action; setup_command <<= action
setup (url_setup_proxy .$ withCString (replace ',' ' ' url_proxy))
setup (url_setup_bypass_list.$ withCString (replace ',' ' ' url_bypass))
-- Çàãðóçèòü ôàéë ëîêàëèçàöèè
setup (setLocale [language])
-- Âðó÷íóþ ðàñêèäàòü îïöèè -o/-op
let (op, o_rest) = partition is_op_option (findReqList o "overwrite")
op_opt = map (tryToSkip "p") op
overwrite = last ("p":o_rest)
is_op_option ('p':_:_) = True
is_op_option _ = False
-- Ïðîâåðèòü, ÷òî îïöèè ïðèíèìàþò îäíî èç äîïóñòèìûõ çíà÷åíèé
testOption "overwrite" "o" overwrite (words "+ - p")
testOption "indicator" "i" indicator (words "0 1 2")
testOption "pretest" "tp" pretest (words "0 1 2 3")
testOption "BrokenArchive" "ba" broken_archive (words "- 0 1")
testOption "ExcludePath" "ep" exclude_path ([""]++words "1 2 3 --")
testOption "pause-before-exit" "" pause_before_exit (words "on off on-warnings on-error")
-- Îïðåäåëèòü èìÿ SFX-ìîäóëÿ, êîòîðûé áóäåò äîáàâëåí â íà÷àëî àðõèâà
let sfxname = findOptArg o "sfx" (if take 1 cmd=="s" then drop 1 cmd else "--") -- êîìàíäà "s..." ýêâèâàëåíòíà êîìàíäå "ch -sfx..."
||| default_sfx archive_type -- ïðè ïóñòîì ïàðàìåòðå èñïîëüçîâàòü ìîäóëü SFX ïî óìîë÷àíèþ (â çàâèñèìîñòè îò òèïà àðõèâà, freearc.sfx/7z.sfx èç êàòàëîãà ïðîãðàììû)
sfx <- if sfxname `notElem` words "- --" && takeFileName sfxname == sfxname
then findFile libraryFilePlaces sfxname -- èñïîëüçîâàòü ìîäóëü ñ çàäàííûì èìåíåì èç ñòàíäàðòíîãî êàòàëîãà
else return sfxname
when (sfx=="") $
registerError$ GENERAL_ERROR ["0342 SFX module %1 is not found", sfxname]
-- Äîáàâèì ê áàçîâîìó èìåíè àðõèâà øòàìï äàòû/âðåìåíè, åñëè óêàçàíà îïöèÿ -ag
current_time <- getClockTime
let add_ag = case autogenerate_arcname of
"--" -> id
_ -> updateBaseName (++ showtime autogenerate_arcname current_time)
-- Äîáàâèì ê èìåíè àðõèâà ðàñøèðåíèå ïî óìîë÷àíèþ, åñëè íåò äðóãîãî ðàñøèðåíèÿ è íå èñïîëüçóåòñÿ îïöèÿ --noarcext
let arcspec = addArcExtension noarcext archive_extension$ add_ag pure_arcspec
-- Îáðàáîòàòü ñïèñîê îïöèé --charset/-sc, âîçâðàòèâ òàáëèöó êîäèðîâîê
-- è ïðîöåäóðû ÷òåíèÿ/çàïèñè ôàéëîâ ñ å¸ ó÷¸òîì
let (charsets, parseFile, unParseFile, parseData, unParseData) = parse_charset_option (findReqList o "charset")
setup (setGlobalCharsets charsets)
-- Âðó÷íóþ îáðàáîòàòü ñïèñîê îïöèé --display
let orig_display = foldl f aDISPLAY_DEFAULT (findReqList o "display")
-- Ôóíêöèÿ îáðàáîòêè îïöèé --display
f value "" = aDISPLAY_ALL -- -di áåç ïàðàìåòðîâ îçíà÷àåò âêëþ÷èòü âûâîä âñåé èíôîðìàöèè
f value "--" = aDISPLAY_DEFAULT -- -di-- îçíà÷àåò âîññòàíîâèòü çíà÷åíèå ïî óìîë÷àíèþ
f value ('+':x) = nub (value++x) -- -di+x îçíà÷àåò äîáàâèòü x ê ôëàãàì
f value ('-':x) = nub value \\ x -- -di-x îçíà÷àåò óáðàòü x èç ôëàãîâ
f value x = nub x -- èíà÷å ïðîñòî ñêîïèðóåì ïàðàìåòð â çíà÷åíèå îïöèè
-- Äëÿ êîìàíäû "lb" ïîëíîñòüþ îòêëþ÷àòü âûâîä äîï. èíôîðìàöèè íà ýêðàí,
-- äëÿ ïðî÷èõ êîìàíä ëèñòèíãà âêëþ÷àòü âûâîä èìåíè àðõèâà â ïðèíóäèòåëüíîì ïîðÿäêå
let display = case () of
_ | cmd=="lb" -> ""
| cmdType cmd==LIST_CMD -> orig_display++"a"
| otherwise -> orig_display
-- Óñòàíîâèòü display_option, ïîñêîëüêó îíà íàì ìîæåò ïîíàäîáèòüñÿ ïðè âûâîäå warning î ñîäåðæèìîì external compressor section
setup (display_option' =: display)
-- Çàðåãèñòðèðóåì îïèñàíèÿ âíåøíèõ óïàêîâùèêîâ èç ñåêöèé [External compressor:...]
let registerExternalCompressors makeWarnings = do
CompressionLib.clearExternalCompressorsTable
for externalSections $ \section -> do
result <- CompressionLib.addExternalCompressor (unlines section)
when (result/=1 && makeWarnings) $ do
registerWarning (BAD_CFG_SECTION "configuration file" section)
-- Çàðåãèñòðèðóåì èõ ñåé÷àñ äëÿ ïàðñèíãà êîìàíäíîé ñòðîêè è ïåðåðåãèñòðèðóåì ïðè âûïîëíåíèè äëÿ ñîáñòâåííî ñæàòèÿ.
registerExternalCompressors True
setup_command <<= (registerExternalCompressors False)
---------------------------------------------------------------------------------------------------
-- ÎÏÐÅÄÅËÅÍÈÅ ÀËÃÎÐÈÒÌÀ ÑÆÀÒÈß -------------------------------------------------------------------
-- Ïàðñåð îáú¸ìîâ ïàìÿòè, âîñïðèíèìàþùèé çàïèñè òèïà "75%" (îò îáú¸ìà ÎÇÓ)
-- Îáú¸ì ïàìÿòè îêðóãëÿåòñÿ äî âåëè÷èíû, êðàòíîé 4 ìá, ÷òîáû èñêëþ÷èòü ïîëó÷åíèå íåêðóãëûõ âåëè÷èí â ðåçóëüòàòå äåéñòâèÿ ðàçëè÷íûõ Shadow BIOS options
let parsePhysMem = parseMemWithPercents (toInteger getPhysicalMemory `roundTo` (4*mb))
-- Ïàðñåð îïöèè -md
let parseDict dictionary = case dictionary of
[c] | isAlpha c -> Just$ 2^(16 + ord c - ord 'a') -- îïöèÿ çàäàíà îäíîé áóêâîé, -mda..-mdz
s@(c:_) | isDigit c -> Just$ parsePhysMem s -- îïöèÿ íà÷èíàåòñÿ c öèôðû: -md8, -md8m, -md10%
otherwise -> Nothing -- èíà÷å - ýòî íå îïöèÿ -md, à îïöèÿ -m, íà÷èíàþùàÿñÿ ñ -md...
-- Öèêë, âðó÷íóþ îáðàáàòûâàþùèé ðàçëè÷íûå îïöèè, íà÷èíàþùèåñÿ íà "-m"
method <- ref ""; methods <- ref ""; dict <- ref 0; change_methods' <- newList
mm' <- ref "--"; threads <- ref 0 ; ma' <- ref "--"
when (archive_type == aFreeArcInternalExt) $ do -- åñëè -tarc, òî îáðàáîòàåì îïöèè -m... äëÿ arc-ôîðìàòà
for compression_options $ \option ->
case option of
-- Syntax: -mc[$group1,$group2][:]-$group,-algo,+algo,algo1/algo2
'c':rest | anyf [beginWith "-", beginWith "+", beginWith ":", beginWith "$", allf [isInfixOf "/", not.isInfixOf "/$"], endWith "-", endWith "+"] rest
-> do let parseGroups xs@('$':_) = do
let (group_str,operation) = break (`elem` ":-+") xs
groups = split ',' group_str
if any (not.beginWith "$") groups -- íàçâàíèÿ ãðóïï äîëæíû íà÷èíàòüñÿ ñ '$'
then registerError$ CMDLINE_BAD_OPTION_FORMAT ("-m"++option)
else return (groups,operation)
--
parseGroups xs = return ([],xs)
--
let rarAbbrevs = changeTo [("d","delta"), ("e","exe"), ("l","lzp"), ("r","rep"), ("z","dict"), ("a","$wav"), ("c","$bmp"), ("t","$text")]
--
let parseOperation operation
| beginWith "+" operation || endWith "+" operation = return ('+', operation .$tryToSkip "+" .$tryToSkipAtEnd "+", "")
| beginWith "-" operation || endWith "-" operation = return ('-', operation .$tryToSkip "-" .$tryToSkipAtEnd "-" .$rarAbbrevs, "")
| (algo1,'/':algo2) <- break (=='/') operation,
algo1 > "", algo2 > "" = return ('/', algo1, algo2)
| otherwise = registerError$ CMDLINE_BAD_OPTION_FORMAT ("-m"++option)
--
-- Split `rest` into list of groups and operation
(groups,operation) <- parseGroups rest
-- Parse `operation` string
(op,algo1,algo2) <- parseOperation (tryToSkip ":" operation)
change_methods' <<= (op, groups.$replace "$default" "", algo1, algo2)
-- Îïöèÿ -md óñòàíàâëèâàåò ðàçìåð ñëîâàðÿ êàê â ñòàðîì äîáðîì RAR :)
'd':rest | Just md <- parseDict rest -> dict =: md
-- Îïöèÿ -mm âûáèðàåò ðåæèì ìóëüòèìåäèà-ñæàòèÿ.
'm':rest | mmflag <- rest.$tryToSkip "=",
mmflag `elem` ["","--","+","-","max","fast"] -> mm' =: mmflag
-- Îïöèÿ -ms çàäà¸ò èñïîëüçîâàíèå áûñòðîãî ìåòîäà ñæàòèÿ äëÿ óæå ñæàòûõ ôàéëîâ
"s" -> methods ++= "/$compressed="++join_compressor aCOMPRESSED_METHOD
"s-" -> change_methods' <<= ('-',[],"$compressed","")
-- Îïöèÿ -ma âûáèðàåò ðåæèì àâòîîïðåäåëåíèÿ òèïîâ ôàéëîâ
'a':rest | maflag <- rest.$tryToSkip "=".$changeTo [("+","--"), ("","--"), ("-","0")],
maflag `elem` ["--"]++map show [0..9] -> ma' =: maflag
-- Îïöèÿ -mt âêëþ÷àåò/âûêëþ÷àåò ìíîãîòðåäîâîñòü è óñòàíàâëèâàåò êîëè÷åñòâî òðåäîâ
't':rest | n <- rest.$tryToSkip "=".$changeTo [("-","1"), ("+","0"), ("","0"), ("--","0")],
all isDigit n -> threads =: readInt n
-- Îïöèè -m$type=method óñòàíàâëèâàþò àëãîðèòìû ñæàòèÿ äëÿ îòäåëüíûõ òèïîâ ôàéëîâ
'$':_ -> case (break (`elem` "=:.") option) of
(_type, '=':method) -> methods ++= '/':option -- -m$type=method: àðõèâèðîâàòü ôàéëû ýòîãî òèïà çàäàííûì êîìïðåññîðîì
-- (_type, ':':names) -> types ++= split ':' names -- -m$type:name1:name2: äîáàâèòü â ñïèñîê ôàéëîâ ýòîãî òèïà çàäàííûå ìàñêè
-- (_type, ',':exts) -> types ++= map ("*."++) $ split '.' exts -- -m$type.ext1.ext2: äîáàâèòü ðàñøèðåíèÿ â ñïèñîê òèïà
otherwise -> registerError$ CMDLINE_BAD_OPTION_FORMAT ("-m"++option)
-- Âñå îñòàëüíûå îïöèè, íà÷èíàþùèåñÿ íà -m0= èëè ïðîñòî -m, çàäàþò îñíîâíîé ìåòîä ñæàòèÿ.
m -> method =: m.$tryToSkip "0="
-- Ïðî÷èòàåì îêîí÷àòåëüíûå çíà÷åíèÿ ïåðåìåííûõ
dictionary <- val dict -- ðàçìåð ñëîâàðÿ (-md)
cthreads <- val threads -- êîëè÷åñòâî compression threads (-mt)
mainMethod <- val method -- îñíîâíîé ìåòîä ñæàòèÿ.
userMethods <- val methods -- äîïîëíèòåëüíûå ìåòîäû äëÿ êîíêðåòíûõ òèïîâ ôàéëîâ (-m$/-ms)
mm <- val mm' -- ìóëüòèìåäèà-ñæàòèå
change_methods <- listVal change_methods' -- ñïèñîê îïåðàöèé, êîòîðûå íóæíî âûïîëíèòü íàä àëãîðèòìàìè ñæàòèÿ
ma <- val ma' -- ðåæèì àâòîîïðåäåëåíèÿ òèïîâ ôàéëîâ
-- Óðîâåíü ñæàòèÿ, 0..9. Ïûòàåìñÿ óãàäàòü åãî ïî öèôðå, íà÷èíàþùåé èëè çàâåðøàþùåé ñòðîêó ñæàòèÿ.
let clevel = case mainMethod of
xs | xs &&& isDigit (head xs) &&& all isAlpha (tail xs) &&& length(xs)<=3 -> digitToInt (head xs)
xs | xs &&& isDigit (last xs) &&& all isAlpha (init xs) &&& length(xs)<=3 -> digitToInt (last xs)
"mx" -> 9
"max" -> 9
_ -> 4 -- default compression level
-- Óðîâåíü àâòîäåòåêòà, 0..9
let ma_opt = case ma of "--" -> clevel
_ -> readInt ma
-- Ïåðåäàòü â áèáëèîòåêó óïàêîâêè êîëè÷åñòâî òðåäîâ, êîòîðîå îíà äîëæíà èñïîëüçîâàòü
let cpus = cthreads ||| i getProcessorsCount -- By default, use number of threads equal to amount of available processors/cores
setup (CompressionLib.setCompressionThreads cpus)
-- Âêëþ÷èòü/âûêëþ÷èòü ðåæèì îòëàäî÷íîãî âûâîäà
setup (CompressionLib.setDebugMode (if display `contains_one_of` "$" then 1 else 0))
-- Îãðàíè÷åíèÿ íà ïàìÿòü ïðè óïàêîâêå/ðàñïàêîâêå
let climit = parseLimit "75%"$ findReqArg o "LimitCompMem" "--"
dlimit = parseLimit d_def$ findReqArg o "LimitDecompMem" "--"
d_def = if cmdType cmd == ADD_CMD then "1600mb" else "75%"
parseLimit deflt x = case x of
"--" -> parsePhysMem deflt -- Ïî óìîë÷àíèþ: îãðàíè÷èòü èñïîëüçîâàíèå ïàìÿòè 75% å¸ ôèçè÷åñêîãî îáú¸ìà ïðè óïàêîâêå, è 1ãá ïðè ðàñïàêîâêå
"-" -> CompressionLib.aUNLIMITED_MEMORY -- Íå îãðàíè÷èâàòü èñïîëüçîâàíèå ïàìÿòè
s -> parsePhysMem s -- Îãðàíè÷èòü èñïîëüçîâàíèå ïàìÿòè çàäàííûì îáú¸ìîì
-- Óïðàâëåíèå ìóëüòèìåäèà-ñæàòèåì
let multimedia mm = case mm of
"-" -> (++"/$wav=/$bmp=") -- óäàëèì ãðóïïû $wav è $bmp èç ñïèñêà ìåòîäîâ ñæàòèÿ.
"fast" -> (++"/$wav=wavfast/$bmp=bmpfast")
"max" -> (++"/$wav=wav/$bmp=bmp")
"+" -> multimedia "max"
"" -> multimedia "+"
"--" -> id
-- Âûïîëíåíèå îïåðàöèé, çàäàííûõ îïöèåé -mc:
let -- óäàëèì ãðóïïó mc (íàïðèìåð, "$bmp") èç ñïèñêà ìåòîäîâ ñæàòèÿ.
changeMethod ('-',groups,group@('$':_),_) = filter ((/=group).fst)
-- 1. óäàëèì ãðóïïû, â êîòîðûõ algo - ïîñëåäíèé àëãîðèòì ñæàòèÿ (íàïðèìåð -mc-tta ïðèâåä¸ò ê óäàëåíèþ ãðóïï, öåïî÷êè ñæàòèÿ êîòîðûõ çàêàí÷èâàþòñÿ àëãîðèòìîì tta)
-- 2. óäàëèì àëãîðèòì algo èç îñòàëüíûõ öåïî÷åê ñæàòèÿ.
changeMethod ('-',groups,algo,_) = processTail (deleteIf ((algo==).method_name.last1.snd)) -- Íå òðîãàåì îñíîâíóþ ãðóïïó ñæàòèÿ (ãîëîâó ñïèñêà)
>>> applyToGroups groups (deleteIf ((algo==).method_name))
-- äîáàâèì çàäàííûé àëãîðèòì ñæàòèÿ.
changeMethod ('+',groups,algo,_) = applyToGroups groups (decode_method_sequence cpus algo++)
-- çàìåíèì àëãîðèòì ñæàòèÿ íà äðóãîé
changeMethod ('/',groups,algo1,algo2) = applyToGroups groups (concatMap (replace algo1 algo2))
where replace algo1 algo2 algo = if method_name algo==algo1 then (decode_method_sequence cpus algo2) else [algo]
-- Ïðèìåíèòü îïåðàöèþ op òîëüêî ê ãðóïïàì, ïåðå÷èñëåííûì â ñïèñêå groups (êî âñåì åñëè ñïèñîê ïóñò)
applyToGroups [] op = mapSnds op
applyToGroups groups op = map (\x@(grp,_) -> if grp `elem` groups then mapSnd op x else x)
-- Åñëè çàäàíà îïöèÿ "--nodata", òî ñèìóëèðîâàòü ñæàòèå äàííûõ.
-- Åñëè çàäàíà îïöèÿ "--crconly", òî îãðàíè÷èòüñÿ ïîäñ÷¸òîì CRC àðõèâèðóåìûõ ôàéëîâ.
--  ïðîòèâíîì ñëó÷àå îáðàáîòàòü âûáðàííûå îñíîâíîé è äîïîëíèòåëüíûå àëãîðèòìû ñæàòèÿ,
-- íàñòðîèâ ìóëüòèìåäèà-ñæàòèå è ðàçìåð ñëîâàðÿ, óäàëèâ îòêëþ÷åííûå àëãîðèòìû,
-- è îãðàíè÷èâ ïîòðåáëåíèå ïàìÿòè
let data_compressor = if nodata then [("", [aFAKE_COMPRESSION])]
else if crconly then [("", [aCRC_ONLY_COMPRESSION])]
else ((mainMethod ||| aDEFAULT_COMPRESSOR) ++ userMethods)
.$ multimedia mm
.$ decode_compression_method cpus
.$ applyAll (map changeMethod change_methods)
.$ setDictionary dictionary
.$ limitMinDecompressionMem dlimit
-- Îãðàíè÷èòü ñæàòèå êàòàëîãà ïîñëåäíèì ìåòîäîì â îñíîâíîé öåïî÷êå è íàëè÷íûì îáú¸ìîì ïàìÿòè
let dir_compressor = orig_dir_compressor.$ limitMinDecompressionMem dlimit
.$ getMainCompressor
.$ reverse .$ take 1
-- Ìàêñ. ðàçìåð áëîêà â èñïîëüçóåìûõ áëî÷íûõ êîìïðåññîðàõ èëè 0
let maxBlockSize = getBlockSize data_compressor
-- Ïàìÿòü, òðåáóåìàÿ äëÿ àëãîðèòìà ñæàòèÿ.
let compressionMem = getCompressionMem data_compressor
-- Âû÷èñëèòü, ñêîëüêî ïàìÿòè íóæíî èñïîëüçîâàòü ïîä áóôåð óïðåæäàþùåãî ÷òåíèÿ ôàéëîâ.
-- Åñëè ðàçìåð êåøà íå çàäàí ÿâíî îïöèåé --cache, ìû èñïîëüçóåì îò 1 äî 16 ìá,
-- ñòàðàÿñü ñäåëàòü òàê, ÷òîáû îáùåå ïîòðåáëåíèå ïàìÿòè ïðîãðàììîé íå ïðåâîñõîäèëî
-- ïîëîâèíû îò å¸ ôèçè÷åñêîãî îáú¸ìà (íå ñ÷èòàÿ ïàìÿòè, íåîáõîäèìîé äëÿ ðàñïàêîâêè äàííûõ
-- â îáíîâëÿåìûõ àðõèâàõ). Ðàçóìååòñÿ, ïðè íàëè÷èè ïàðàëëåëüíî âûïîëíÿþùèõñÿ memory-intensive
-- tasks (è â ÷àñòíîñòè, ïàðàëëåëüíî ðàáîòàþùèõ êîïèÿõ FreeArc) ýòà òàêòèêà íå î÷åíü óäà÷íà.
-- To do: ëó÷øå áûëî áû ñìîòðåòü íà îáú¸ì *ñâîáîäíîãî* ôèçè÷åñêîãî ÎÇÓ + äèñêîâîãî êåøà ÎÑ â ìîìåíò çàïóñêà ïðîãðàììû.
let minCache = 1*aIO_BUFFER_SIZE -- Ìèí. ðàçóìíûé ðàçìåð êåøà ïðè ñæàòèè
maxCache = 16*mb -- Ìàêñ. ðàçìåð êåøà - 16 ìá
availCMem = i(parsePhysMem "50%" `min` climit) `minusPositive` compressionMem -- "Ñâîáîäíî ïàìÿòè" = min(50% ÎÇÓ,lc) ìèíóñ ïàìÿòü, òðåáóåìàÿ äëÿ ñæàòèÿ.
compression_cache = clipToMaxInt $
case (findReqArg o "cache" "--") of
"--" -> availCMem.$clipTo minCache maxCache
"-" -> minCache
s -> parsePhysMem s
decompression_cache = clipToMaxInt $
case (findReqArg o "cache" "--") of
"--" -> 4*aIO_BUFFER_SIZE
"-" -> 0
s -> parsePhysMem s
-- Àâòîìàòè÷åñêè âêëþ÷èòü îïöèþ --recompress äëÿ êîìàíä, êîïèðóþùèõ àðõèâ,
-- åñëè óêàçàíû îïöèè -m../--nodata/--crconly
let recompress = findNoArg o "recompress"
|| (is_COPYING_COMMAND cmd && (mainMethod>"" || nodata || crconly))
-- Íå ïåðåïàêîâûâàòü ñóùåñòâóþùèå ñîëèä-áëîêè â àðõèâå ïðè --append
-- è â êîìàíäàõ êîïèðîâàíèÿ àðõèâà, åñëè --recompress íå çàäàíî ÿâíî
let keep_original = findNoArg o "append"
|| (is_COPYING_COMMAND cmd && not recompress)
---------------------------------------------------------------------------------------------------
-- ÏÐÅÄÈÊÀÒÛ ÄËß ÎÏÐÅÄÅËÅÍÈß ÍÎÌÅÐÀ ÃÐÓÏÏÛ (find_group) È ÒÈÏÀ ÔÀÉËÀ (find_type) ------------------
-- Îïðåäåëèòü, êàêîé ôàéë ñî ñïèñêîì ãðóïï (òèïà arc.groups) áóäåò èñïîëüçîâàòüñÿ.
actual_group_file <- case (findReqArg o "groups" "--") of
"--" -> findFile configFilePlaces aDEFAULT_GROUPS_FILE -- èñïîëüçîâàòü ôàéë ãðóïï ïî óìîë÷àíèþ (arc.groups èç êàòàëîãà, ãäå íàõîäèòñÿ ïðîãðàììà)
"-" -> return "" -- ôàéë ãðóïï îòêëþ÷åí îïöèåé --groups-
x -> return x -- ôàéë ãðóïï óêàçàí ÿâíî îïöèåé --groups=FILENAME
-- Ïðî÷èòàòü ñïèñîê ãðóïï èç ôàéëà ãðóïï
group_strings <- if actual_group_file > ""
then parseFile 'i' actual_group_file -- ðàñïàðñèòü ôàéë ãðóïï ñ ó÷¸òîì êîäèðîâêè ñèìâîëîâ è ðàçäåëèòåëåé ñòðîê
>>== map translatePath -- ïðåâðàòèòü âñå '\' â '/'
>>== deleteIfs [match ";*", null] -- óäàëèòü ñòðîêè êîììåíòàðèåâ è ïóñòûå
else return [reANY_FILE] -- åñëè ôàéë ãðóïï íå èñïîëüçóåòñÿ, òî âñå ôàéëû ïðèíàäëåæàò îäíîé îáùåé ãðóïïå
-- Ñïèñîê ïðåäèêàòîâ, ïðîâåðÿþùèõ âõîæäåíèå â êàæäóþ ãðóïïó
let group_predicates = map (match_FP fpBasename) group_strings
-- Ãðóïïà ïî óìîë÷àíèþ, êóäà ïîïàäàþò âñå ôàéëû, íå ñîâïàäàþùèå íè ñ îäíîé èç ìàñîê.
-- Óêàçûâàåòñÿ ïñåâäî-ìàñêîé "$default", ïðè å¸ îòñóòñòâèè ñ÷èòàåòñÿ, ÷òî ýòà ìàñêà äîáàâëåíà â êîíåö ñïèñêà
let lower_group_strings = (map strLower group_strings) ++ ["$default"]
default_group = "$default" `elemIndex` lower_group_strings .$ fromJust
-- Ôóíêöèÿ "PackedFilePath -> íîìåð ãðóïïû èç arc.groups"
let find_group = findGroup group_predicates default_group
-- Ñïèñîê òèïîâ ôàéëîâ ($text, $exe è òàê äàëåå), ñîîòâåòñòâóþùèõ êàæäîé ãðóïïå èç arc.groups
let group_type_names = go "$binary" lower_group_strings -- íà÷àëüíàÿ ãðóïïà - "$binary"
go t [] = [] -- ïðîéòè ïî ñïèñêó ãðóïï, çàìåíÿÿ ìàñêè ôàéëîâ
go t (x:xs) = case x of -- íà ïðåäøåñòâóþùèå èì èìåíà òèïîâ ôàéëîâ ("$text", "$rgb" è òàê äàëåå)
'$':_ | x/="$default" -> x : go (proper_type x) xs
_ -> t : go t xs
-- Ïåðâûé òèï èç ñïèñêà ñëîâ x, âõîäÿùèé â compressor_types
proper_type x = (find (`elem` compressor_types) (words x)) `defaultVal` ""
-- Ñïèñîê òèïîâ ôàéëîâ, èñïîëüçóåìûõ â data_compressor (âûáðàííîì ïîëüçîâàòåëåì ìåòîäå ñæàòèÿ)
compressor_types = map fst data_compressor
-- Ñïèñîê íîìåðîâ ìåòîäîâ ñæàòèÿ èç ñïèñêà `data_compressor`, ñîîòâåòñòâóþùèõ êàæäîé ãðóïïå èç arc.groups
let group_types = map typeNum group_type_names
typeNum t = (t `elemIndex` compressor_types) `defaultVal` 0
-- Ñïèñîê ïðåäèêàòîâ, ïðîâåðÿþùèõ ÷òî ôàéë ïðèíàäëåæèò îäíîìó èç òèïîâ, ïåðå÷èñëåííûõ â `data_compressor`
let type_predicates = const False : map match_type [1..maximum group_types]
match_type t = any_function$ concat$ zipWith (\a b->if a==t then [b] else []) group_types group_predicates
-- Ôóíêöèÿ "PackedFilePath -> íîìåð êîìïðåññîðà â ñïèñêå `data_compressor`"
let find_type = findGroup type_predicates 0
-------------------------------------------------------------------------------------
-- ÔÈËÜÒÐ ÔÀÉËÎÂ
let match_with = findNoArg o "fullnames" .$bool fpBasename fpFullname
orig_include_list = findReqList o "include"
orig_exclude_list = findReqList o "exclude"
include_dirs = findNoArgs o "dirs" "nodirs"
clear_archive_bit = findNoArg o "ClearArchiveBit"
select_archive_bit = findNoArg o "SelectArchiveBit"
filesize_greater_than = findReqArg o "SizeMore" "--"
filesize_less_than = findReqArg o "SizeLess" "--"
time_before = findReqArg o "TimeBefore" "--"
time_after = findReqArg o "TimeAfter" "--"
time_newer = findReqArg o "TimeNewer" "--"
time_older = findReqArg o "TimeOlder" "--"
-- Çàìåíèì ññûëêè íà ëèñò-ôàéëû (@listfile/-n@listfile/-x@listfile) èõ ñîäåðæèìûì
listed_filespecs <- pure_filespecs .$ replace_list_files parseFile >>== map translatePath
include_list <- orig_include_list.$ replace_list_files parseFile >>== map translatePath
exclude_list <- orig_exclude_list.$ replace_list_files parseFile >>== map translatePath
-- Ïðåäèêàòû îòáîðà âêëþ÷àåìûõ (-n) è èñêëþ÷àåìûõ (-x) ôàéëîâ. Äëÿ -n ïðîâåðÿåì orig_include_list, ïîñêîëüêó ïðè ïóñòîì ëèñòôàéëå íè îäèí ôàéë íå äîëæåí ïðîõîäèòü ôèëüòð
let match_included = orig_include_list &&& [match_filespecs match_with include_list]
match_excluded = exclude_list &&& [match_filespecs match_with exclude_list]
#if defined(FREEARC_WIN)
-- Îòáîð ôàéëîâ ïî àòðèáóòàì
let attrib_filter | select_archive_bit = [\attr -> attr.&.fILE_ATTRIBUTE_ARCHIVE /= 0]
| otherwise = []
#else
let attrib_filter = []
#endif
-- Îòáîð ôàéëîâ ïî ðàçìåðó
let size_filter _ "--" = []
size_filter op option = [(`op` parseSize 'b' option)]
-- Îòáîð ôàéëîâ ïî âðåìåíè ìîäèôèêàöèè, time â ôîðìàòå YYYYMMDDHHMMSS
let time_filter _ "--" = []
time_filter op time = [(`op` (time.$makeCalendarTime.$toClockTime.$convert_ClockTime_to_CTime))]
-- Ïðåîáðàçóåò ñòðî÷êó âèäà YYYY-MM-DD_HH:MM:SS â CalendarTime è âûñòàâëÿåò êîððåêòíîå ctTZ â çàâèñèìîñòè îò å¸ âðåìåíè ãîäà (äëÿ ýòîãî toCalendarTime.toClockTime äåëàåòñÿ äâàæäû)
makeCalendarTime str = ct {ctTZ = ctTZ$ unsafePerformIO$ toCalendarTime$ toClockTime ct2}
where ct2 = ct {ctTZ = ctTZ$ unsafePerformIO$ toCalendarTime$ toClockTime ct}
ct = CalendarTime
{ ctYear = readInt (take 4 s)
, ctMonth = readInt (take 2 $ drop 4 s) .$ (\x->max(x-1)0) .$ toEnum
, ctDay = readInt (take 2 $ drop 6 s)
, ctHour = readInt (take 2 $ drop 8 s)
, ctMin = readInt (take 2 $ drop 10 s)
, ctSec = readInt (take 2 $ drop 12 s)
, ctPicosec = 0
, ctWDay = error "ctWDay"
, ctYDay = error "ctYDay"
, ctTZName = error "ctTZName"
, ctTZ = 0
, ctIsDST = error "ctIsDST"
}
s = filter isDigit str ++ repeat '0'
-- Îòáîð ôàéëîâ ïî "ñòàðîñòè", time â ôîðìàòå [<ndays>d][<nhours>h][<nminutes>m][<nseconds>s]
let oldness_filter _ "--" = []
oldness_filter op time = [(`op` (time.$calcDiff.$(`addToClockTime` current_time).$convert_ClockTime_to_CTime))]
calcDiff = foldl updateTD noTimeDiff . recursive (spanBreak isDigit)
updateTD td x = case (last x) of
'd' -> td {tdDay = -readInt (init x)}
'h' -> td {tdHour = -readInt (init x)}
'm' -> td {tdMin = -readInt (init x)}
's' -> td {tdSec = -readInt (init x)}
_ -> td {tdDay = -readInt x}
-- Ôèëüòð îòáîðà ôàéëîâ, âêëþ÷àþùèé âñå êðèòåðèè îòáîðà,
-- óêàçàííûå â êîìàíäíîé ñòðîêå, êðîìå îòáîðà ïî filespecs.
-- Äëÿ ïîñëåäíèõ èñïîëüçóåòñÿ îòäåëüíàÿ ôóíêöèÿ,
-- ïîòîìó ÷òî îíè ïî-ðàçíîìó èñïîëüçóþòñÿ â êîìàíäàõ ðàçíîãî òèïà.
let file_filter = all_functions$
concat [ attrib_filter .$map (.fiAttr)
, map (not.) match_excluded .$map (.fiFilteredName)
, nst_filters
]
nst_filters = concat [ match_included .$map (.fiFilteredName)
, size_filter (>) filesize_greater_than .$map (.fiSize)
, size_filter (<) filesize_less_than .$map (.fiSize)
, time_filter (>=) time_after .$map (.fiTime)
, time_filter (<) time_before .$map (.fiTime)
, oldness_filter (>=) time_newer .$map (.fiTime)
, oldness_filter (<) time_older .$map (.fiTime)
]
-- Åñëè èìåíà îáðàáàòûâàåìûõ ôàéëîâ íå óêàçàíû è êîìàíäà íå cw/d, òî îáðàáàòûâàòü âñå ôàéëû
filespecs <- case listed_filespecs of
[] | cmd `elem` (words "cw d") -> registerError$ CMDLINE_NO_FILENAMES args
| otherwise -> return aDEFAULT_FILESPECS
_ | cmd.$is_CMD_WITHOUT_ARGS -> registerError$ CMDLINE_GENERAL ["0377 command \"%1\" shouldn't have additional arguments", cmd]
| otherwise -> return listed_filespecs
-- Âêëþ÷àòü êàòàëîãè â îáðàáîòêó? Ýòà ïåðåìåííàÿ èñïîëüçóåòñÿ òîëüêî ïðè ëèñòèíãå/ðàñïàêîâêå
let x_include_dirs = case include_dirs of
Just x -> x -- â ñîîòâåòñòâèè ñ îöèÿìè --dirs/--nodirs
_ -> -- ÄÀ, åñëè îáðàáàòûâàþòñÿ âñå ôàéëû, íåò ôèëüòðîâ -n/-s*/-t* è êîìàíäà íå "e"
filespecs==aDEFAULT_FILESPECS && null nst_filters && cmd/="e"
-------------------------------------------------------------------------------------
-- ØÈÔÐÎÂÀÍÈÅ
-- Àëãîðèòì øèôðîâàíèÿ; ïðîâåðêà âàëèäíîñòè è ïðèâåäåíèå ê êàíîíè÷åñêîìó âèäó ("aes" -> "aes-256/ctr")
let ea = findReqArg o "encryption" aDEFAULT_ENCRYPTION_ALGORITHM
encryptionAlgorithm <- join_compressor ==<< (foreach (split_compressor ea) $ \algorithm -> do
unless (isEncryption algorithm) $ do
registerError$ CMDLINE_GENERAL ["0378 bad name or parameters in encryption algorithm %1", algorithm]
return$ CompressionLib.canonizeCompressionMethod algorithm)
-- Ïàðîëè äëÿ äàííûõ è çàãîëîâêà àðõèâà
let (dpwd,hpwd) = case (findReqArg o "password" "--" .$changeTo [("-", "--")]
,findReqArg o "HeadersPassword" "--" .$changeTo [("-", "--")])
of
(p, "--") -> (p, "--") -- -p...
("--", p ) -> (p, p ) -- -hp..,
(p, "" ) -> (p, p ) -- -p[PWD] -hp
("", p ) -> (p, p ) -- -p -hpPWD
(p1, p2 ) -> (p1, p2 ) -- -pPWD1 -hpPWD2
-- Çàïðåòèòü çàïðîñ ïàðîëåé, íåîáõîäèìûõ äëÿ ðàñïàêîâêè, åñëè óêàçàíî -op-/-p-/-hp-
let dont_ask_passwords = last ("":op_opt) == "-" || findReqArg o "OldPassword" "" == "-" || findReqArg o "password" "" == "-" || findReqArg o "HeadersPassword" "" == "-"
-- Ñïèñîê ïàðîëåé, èñïîëüçóåìûõ ïðè ðàñïàêîâêå
mvar_unpack_passwords <- newMVar$ deleteIfs [(==""),(=="?"),(=="-"),(=="--")]$ op_opt ++ findReqList o "OldPassword" ++ findReqList o "password" ++ findReqList o "HeadersPassword"
-- Ñîäåðæèìîå êëþ÷åâûõ ôàéëîâ, èñïîëüçóåìûõ ïðè ðàñïàêîâêå
oldKeyfileContents <- mapM fileGetBinary (findReqList o "OldKeyfile" ++ findReqList o "keyfile")
-- Ñîäåðæèìîå êëþ÷åâîãî ôàéë, èñïîëüçóåìîãî ïðè óïàêîâêå
keyfileContents <- unlessNull fileGetBinary (findReqArg o "keyfile" "")
-- Òðåáóåòñÿ ââîä ïàðîëÿ ñ êëàâèàòóðû ïðè -p? è ïðè -p, åñëè íåò êëþ÷åâîãî ôàéëà
let askPwd pwd = pwd=="?" || (pwd=="" && keyfileContents=="")
-- Ðåöåïò ïîäãîòîâêè êîìàíäû ê èñïîëüçîâàíèþ øèôðîâàíèÿ, èëè Nothing äî ñîçäàíèÿ ðåöåïòà
receipt <- newMVar Nothing
-- Ïîäãîòàâëèâàåò command ê èñïîëüçîâàíèþ øèôðîâàíèÿ, ïðè íåîáõîäèìîñòè
-- çàïðàøèâàÿ ïàðîëü ó ïîëüçîâàòåëÿ è ñ÷èòûâàÿ keyfiles
let cookPasswords command (ask_encryption_password, ask_decryption_password, bad_decryption_password) = do
modifyMVar receipt $ \x -> do
f <- x.$maybe makeReceipt return -- ñîçäàòü ðåöåïò ïîäãîòîâêè êîìàíäû ê øèôðîâàíèþ, åñëè åãî åù¸ íåò
return (Just f, f command) -- ïðèìåíèòü ðåöåïò ê command è çàïîìíèòü åãî äëÿ ïîñëåäóþùèõ ïðèìåíåíèé
where
makeReceipt = do
-- Çàïðîñèì ó ïîëüçîâàòåëÿ ïàðîëü, åñëè îí ïîòðåáóåòñÿ íàì äàëüøå
let ask_password | cmdType cmd==ADD_CMD = ask_encryption_password parseData
| otherwise = ask_decryption_password parseData
asked_password <- any askPwd [dpwd,hpwd] &&& ask_password
-- Äîáàâèì â ñïèñîê ïàðîëåé ðàñïàêîâêè ââåä¸ííûé ïîëüçîâàòåëåì ïàðîëü è ïóñòîé ïàðîëü, åñëè äëÿ ðàñøèôðîâêè ìîæåò áûòü èñïîëüçîâàí keyfile
asked_password &&& modifyMVar_ mvar_unpack_passwords (return.(asked_password:))
oldKeyfileContents &&& modifyMVar_ mvar_unpack_passwords (return.("":))
-- Äîáàâèòü ê ïàðîëþ ñîäåðæèìîå keyfile è çàìåíèòü îáîçíà÷åíèÿ "--"/"?". 0.75: äîáàâèòü unicode2utf8 asked_password/pwd
let cook "--" = "" -- øèôðîâàíèå îòêëþ÷åíî
cook pwd | askPwd pwd = asked_password++keyfileContents -- ïàðîëü, ââåä¸íûé ñ êëàâèàòóðû + ñîäåðæèìîå keyfile
| otherwise = pwd++keyfileContents -- ïàðîëü èç êîìàíäíîé ñòðîêè + ñîäåðæèìîå keyfile
return$ \command ->
command { opt_data_password = cook dpwd
, opt_headers_password = cook hpwd
, opt_decryption_info = (dont_ask_passwords, mvar_unpack_passwords, oldKeyfileContents, ask_decryption_password parseData, bad_decryption_password)}
-------------------------------------------------------------------------------------
-- ÏÐÎ×ÅÅ ÏÎ ÌÅËÎ×È
-- Àëãîðèòì îáíîâëåíèÿ àðõèâà
let update_type = case cmd of
"f" -> 'f' -- êîìàíäà f: îáíîâèòü ôàéëû áîëåå ñâåæèìè âåðñèÿìè, íîâûõ ôàéëîâ íå äîáàâëÿòü
"u" -> 'u' -- êîìàíäà u: îáíîâèòü ôàéëû áîëåå ñâåæèìè âåðñèÿìè è äîáàâèòü íîâûå ôàéëû
_ | findNoArg o "freshen" -> 'f' -- îïöèÿ -f: ñì. âûøå
| findNoArg o "update" -> 'u' -- îïöèÿ -u: ñì. âûøå
| findNoArg o "sync" -> 's' -- îïöèÿ --sync: ïðèâåñòè ôàéëû â àðõèâå â ñîîòâåòñòâèå ñ ôàéëàìè íà äèñêå
| otherwise -> 'a' -- èíà÷å: çàìåíèòü ôàéëû â àðõèâå íà âçÿòûå ñ äèñêà è äîáàâèòü íîâûå ôàéëû
-- Çàêðûòü àðõèâ îò èçìåíåíèé, åñëè èñïîëüçîâàíà îïöèÿ "-k" èëè êîìàíäà "k"
let lock_archive = findNoArg o "lock" || cmd=="k"
-- Óäàëèòü àðõèâèðóåìûå ôàéëû, åñëè èñïîëüçîâàíà îïöèÿ "-d[f]" èëè êîìàíäà "m[f]"
delete_files <- case (findNoArg o "delete" || cmd=="m"
,findNoArg o "delfiles" || cmd=="mf")
of
(False, False) -> return NO_DELETE
(False, True ) -> return DEL_FILES
(True , False) -> return DEL_FILES_AND_DIRS
(True , True ) -> registerError$ CMDLINE_INCOMPATIBLE_OPTIONS "m/-d" "mf/-df"
-- Çàïðåòèì èñïîëüçîâàíèå íåñîâìåñòèìûõ îïöèé
when (clear_archive_bit && delete_files/=NO_DELETE) $
registerError$ CMDLINE_INCOMPATIBLE_OPTIONS "m[f]/-d[f]" "-ac"
-- Êàòàëîã äëÿ âðåìåííûõ ôàéëîâ - ìîæåò áûòü óêàçàí ÿâíî èëè ÷åðåç ïåðåìåííóþ ñðåäû
-- "" îçíà÷àåò èñïîëüçîâàíèå ñòàíä. äëÿ ÎÑ êàòàëîãà âðåìåííûõ ôàéëîâ
workdir <- case orig_workdir of
'%':envvar -> getEnv envvar
dir -> return dir
setup_command <<= (setTempDir workdir)
-- Îïðåäåëèòü ïîðÿäîê ñîðòèðîâêè ôàéëîâ â àðõèâå
let sort_order = case (orig_sort_order, group_data) of
(Just "-", _) -> "" -- Åñëè ïîðÿäîê ñîðòèðîâêè çàäàí êàê "-", òî îòêëþ÷èòü ñîðòèðîâêó
(Just x, _) -> x -- Åñëè ïîðÿäîê ñîðòèðîâêè áûë ÿâíî óêàçàí, òî èñïîëüçîâàòü åãî
(_, [GroupNone]) -> "" -- Åñëè íå èñïîëüçóåòñÿ solid-ñæàòèå - îòêëþ÷èòü ñîðòèðîâêó
_ -> if getMainCompressor data_compressor
.$anyf [(==aNO_COMPRESSION), isFakeCompressor, isVeryFastCompressor]
then "" -- Åñëè -m0/--nodata/--crconly/tor:1..4/lzp:h13..15 - òàêæå îòêëþ÷èòü ñîðòèðîâêó
else aDEFAULT_SOLID_SORT_ORDER -- Èíà÷å - èñïîëüçîâàòü ñòàíäàðòíûé ïîðÿäîê ñîðòèðîâêè äëÿ solid-àðõèâîâ
-- Ïðîâåðèì, ÷òî îïöèÿ "-rr" ïðèíèìàåò îäíî èç äîïóñòèìûõ çíà÷åíèé
let rr_ok = recovery `elem` ["","-","--"]
|| snd(parseNumber recovery 'b') `elem` ['b','%','p']
|| ';' `elem` recovery
|| '*' `elem` recovery
unless rr_ok $ do
registerError$ INVALID_OPTION_VALUE "recovery" "rr" ["MEM", "N", "N%", "MEM;SS", "N%;SS", "N*SS", "-", ""]
-- Ñîñòîÿíèå çàïðîñà ê ïîëüçîâàòåëþ î ïåðåçàïèñè ôàéëîâ
ref_overwrite <- newIORef$ case (yes, overwrite) of
(_, "+") -> "a"
(_, "-") -> "s"
(True, _ ) -> "a"
(False, "p") -> " "
-- Ñïèñîê äåéñòâèé, êîòîðûå íàäî âûïîëíèòü íåïîñðåäñòâåííî ïåðåä íà÷àëîì âûïîëíåíèÿ êîìàíäû
setup_command' <- listVal setup_command >>== sequence_
------------------------------------------------------------------------------------------------
-- Çàíåñ¸ì âñ¸ ýòî â ñòðóêòóðó, ïðåäñòàâëÿþùóþ âûïîëíÿåìóþ êîìàíäó â ïîñëåäóþùåé ÷àñòè ïðîãðàììû
return$ Just$ Command {
cmd_args = args
, cmd_additional_args = additional_args
, cmd_name = cmd
, cmd_arcspec = arcspec
, cmd_arclist = error "Using uninitialized cmd_arclist"
, cmd_arcname = error "Using uninitialized cmd_arcname"
, cmd_archive_filter = error "Using uninitialized cmd_archive_filter"
, cmd_filespecs = filespecs
, cmd_added_arcnames = return []
, cmd_diskfiles = return []
, cmd_subcommand = False
, cmd_setup_command = setup_command'
, opt_scan_subdirs = findNoArg o "recursive"
, opt_add_dir = findNoArg o "adddir"
, opt_add_exclude_path = add_exclude_path
, opt_dir_exclude_path = dir_exclude_path
, opt_arc_basedir = findReqArg o "arcpath" "" .$ translatePath .$ dropTrailingPathSeparator
, opt_disk_basedir = findReqArg o "diskpath" "" .$ translatePath .$ dropTrailingPathSeparator
, opt_no_nst_filters = null nst_filters
, opt_file_filter = file_filter
, opt_group_dir = group_dir
, opt_group_data = group_data
, opt_data_compressor = data_compressor
, opt_dir_compressor = dir_compressor
, opt_autodetect = ma_opt
, opt_include_dirs = include_dirs
, opt_indicator = indicator
, opt_display = display
, opt_overwrite = ref_overwrite
, opt_keep_time = findNoArg o "keeptime"
, opt_time_to_last = findNoArg o "timetolast"
, opt_global_queueing = global_queueing_opt
, opt_test = test_opt
, opt_pretest = readInt pretest
, opt_keep_broken = findNoArg o "keepbroken"
, opt_match_with = match_with
, opt_append = findNoArg o "append"
, opt_recompress = recompress
, opt_keep_original = keep_original
, opt_noarcext = noarcext
, opt_nodir = findNoArg o "nodir"
, opt_nodates = findNoArg o "nodates"
, opt_compression_cache = compression_cache
, opt_decompression_cache = decompression_cache
, opt_update_type = update_type
, opt_x_include_dirs = x_include_dirs
, opt_sort_order = sort_order
, opt_reorder = False
, opt_find_group = find_group . fiFilteredName
, opt_groups_count = length group_strings
, opt_find_type = find_type . fiFilteredName
, opt_types_count = maximum group_types + 1
, opt_group2type = (listArray0 group_types!)
, opt_arccmt_file = findOptArg o "arccmt" (if cmd=="c" then "" else "--") -- êîìàíäà "c" ýêâèâàëåíòíà êîìàíäå "ch -z"
, opt_arccmt_str = findReqArg o "archive-comment" ""
, opt_lock_archive = lock_archive
, opt_sfx = sfx
, opt_logfile = findReqArg o "logfile" ""
, opt_delete_files = delete_files
, opt_create_in_workdir = create_in_workdir
, opt_clear_archive_bit = clear_archive_bit
, opt_language = language
, opt_recovery = recovery
, opt_broken_archive = broken_archive
, opt_original = findOptArg o "original" "--"
, opt_save_bad_ranges = findReqArg o "save-bad-ranges" ""
, opt_pause_before_exit = pause_before_exit
, opt_shutdown = shutdown
, opt_limit_compression_memory = climit
, opt_limit_decompression_memory = dlimit
, opt_volumes = findReqList o "volume" .$lastElems 1 .$map (parseSize 'm')
, opt_archive_type = archive_type
, opt_archive_extension = archive_extension
, opt_7z_compression = compression_options
, opt_encryption_algorithm = encryptionAlgorithm
, opt_cook_passwords = cookPasswords
, opt_data_password = error "opt_data_password used before cookPasswords!"
, opt_headers_password = error "opt_headers_password used before cookPasswords!"
, opt_decryption_info = error "opt_decryption_info used before cookPasswords!"
, opt_parseFile = parseFile
, opt_unParseFile = unParseFile
, opt_parseData = parseData
, opt_unParseData = unParseData
}
{-# NOINLINE testOption #-}
-- |Ïðîâåðèòü, ÷òî îïöèÿ ïðèíèìàåò îäíî èç ðàçðåø¸ííûõ çíà÷åíèé
testOption fullname shortname option valid_values = do
unless (option `elem` valid_values) $ do
registerError$ INVALID_OPTION_VALUE fullname shortname valid_values
{-# NOINLINE addArcExtension #-}
-- |Åñëè èìÿ àðõèâà íå ñîäåðæèò ðàñøèðåíèÿ è íå èñïîëüçóåòñÿ îïöèÿ --noarcext,
-- òî äîáàâèòü ê íåìó ðàñøèðåíèå ïî óìîë÷àíèþ
addArcExtension noarcext default_ext filespec =
case (hasExtension filespec, noarcext) of
(False, False) -> filespec ++ default_ext
_ -> filespec
{-# NOINLINE replace_list_files #-}
-- |Çàìåíèòü ññûëêè íà ëèñò-ôàéëû ("@listfile") èõ ñîäåðæèìûì
replace_list_files parseFile = concatMapM $ \filespec ->
case (startFrom "@" filespec) of
Just listfile -> parseFile 'l' listfile >>== map removeComment >>== deleteIf null
_ -> return [filespec]
where
-- Remove "//" comment and preceding spaces from the string
removeComment str | pos:_ <- strPositions str "//" = str .$take pos .$trimRight
| otherwise = str
-- |Åñëè êîì. ñòðîêà ïðåäñòàâëåíà â âèäå îäíîãî ïàðàìåòðà @cmdfile, òî íàäî ïðî÷èòàòü å¸ èç óêàçàííîãî ôàéëà
processCmdfile args =
case args of
['@':cmdfile] -> fileGetBinary cmdfile >>== utf8_to_unicode >>== splitArgs
_ -> return args
where -- Ðàçáèâàåò ñòðîêó ñ ïàðàìåòðàìè íà îòäåëüíûå àðãóìåíòû (îáðàòíàÿ îïåðàöèÿ ê unparseCommand)
splitArgs = parseArg . dropWhile isSpace
parseArg "" = []
-- èìèòèðîâàòü âèíäîâûé ðàçáîðùèê êîì. ñòðîêè: "param" -> param, "dir\\" -> dir\ --
parseArg ('"':rest) = let (arg,_:rest1) = break (=='"') rest
in (replaceAtEnd "\\\\" "\\" arg):splitArgs rest1
parseArg rest = let (arg,rest1) = break isSpace rest
in arg:splitArgs rest1
-- |Ðàçáîð ïàðàìåòðîâ îïöèè "-s"
parseSolidOption opt =
case (split ';' opt) of
[] -> ([aDEFAULT_DIR_GROUPING], [GroupAll], "") -- "-s" âêëþ÷àåò îáùèé ñîëèä-áëîê äëÿ âñåõ ôàéëîâ â îäíîì êàòàëîãå àðõèâà
["-"] -> ([aDEFAULT_DIR_GROUPING], [GroupNone], "") -- "-s-" îòêëþ÷àåò ñîëèä-ñæàòèå, äëÿ êàòàëîãîâ èñïîëüçóåòñÿ ñòàíäàðòíàÿ ãðóïïèðîâêà
["7z"] -> ([GroupAll], [GroupAll], "") -- "-s=7z" äåëàåò îáùèé ñæàòûé êàòàëîã è îäèí ñîëèä-áëîê äëÿ âñåõ ôàéëîâ â àðõèâå
["cab"] -> ([GroupAll], [GroupAll], "0") -- -dm0 -- "-s=cab" äåëàåò îáùèé íåñæàòûé êàòàëîã è îäèí ñîëèä-áëîê äëÿ âñåõ ôàéëîâ â àðõèâå
["zip"] -> ([GroupAll], [GroupNone], "0") -- -dm0 -- "-s=zip" äåëàåò îòäåëüíûé ñîëèä-áëîê äëÿ êàæäîãî ôàéëà â àðõèâå, è îáùèé íåñæàòûé êàòàëîã
["arj"] -> ([GroupNone], [GroupNone], "0") -- -dm0 -- "-s=arj" äåëàåò îòäåëüíûé ñîëèä-áëîê è êàòàëîã äëÿ êàæäîãî ôàéëà â àðõèâå
[dat] -> ([aDEFAULT_DIR_GROUPING], parse dat, "") -- "-sXXX" çàäà¸ò ãðóïïèðîâêó òîëüêî äëÿ ñîëèä-áëîêîâ, êàòàëîãè ãðóïïèðóþòñÿ ñòàíäàðòíî
[dir,dat] -> (parse dir, parse dat, "") -- "-sXXX;YYY" çàäà¸ò ãðóïïèðîâêó è äëÿ êàòàëîãîâ, è äëÿ ñîëèä-áëîêîâ
where
-- Ðàçáîðùèê îïèñàíèÿ ãðóïïèðîâêè ôàéëîâ:
-- "-s/-se/-s10m/-s100f" - ãðóïïèðîâàòü âñå/ïî ðàñøèðåíèþ/ïî 10 ìá/ïî 100 ôàéëîâ, ñîîòâåòñòâåííî.
-- `parse1` îáðàáàòûâàåò îäíî îïèñàíèå ãðóïïèðîâêè,
-- à `parse` - èõ ïîñëåäîâàòåëüíîñòü, íàïðèìåð -se100f10m
parse = map parse1 . recursive (split "")
where split text "" = (reverse text, "")
split "" ('e':xs) = ("e", xs)
split text ('e':xs) = (reverse text, 'e':xs)
split text (x:xs) | not (isDigit x) = (reverse (x:text), xs)
| otherwise = split (x:text) xs
parse1 s = case s of
"" -> GroupAll
"e" -> GroupByExt
_ -> case (parseNumber s 'f') of
(num, 'b') -> GroupBySize (i num)
(1, 'f') -> GroupNone
(num, 'f') -> GroupByNumber (i num)
_ -> error$ "bad solid grouping option '"++s++"'"