/
sl
executable file
·1227 lines (1043 loc) · 48.4 KB
/
sl
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
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
#!/usr/bin/tclsh
#
# sl - usefully organize directories and point out interesting files
# Invented by Tom Phelps on December 30, 2011.
#
# home site: http://www.PracticalThought.com/
#
# Copyright (c) 2011-2012 Thomas A. Phelps
# Licensed under the GNU Public License version 3 (http://www.gnu.org/licenses/).
# NO WARRANTY.
#
#
# $Revision: 1.89 $ $Date: 2012/02/20 04:20:46 $
#
if {[package vcompare [info patchlevel] 8.5] < 0} { puts stderr "ERROR: requires Tcl 8.5"; exit 1 }
if { ![catch {set tty [exec stty -a]}] && [regexp {(\d+)\s+columns} $tty all TERMINFO(width)]} {
} elseif {[info exists env(COLUMNS)]} {set TERMINFO(width) $env(COLUMNS)
} else {set TERMINFO(width) 80}
array set TIME [list SECOND 1 MINUTE [expr 60] HOUR [expr 60*60] DAY [expr 60*60*24] MONTH [expr 60*60*24*30] YEAR [expr 60*60*24*365]]
array set TIME [list now [clock seconds]]
set TIME(epsilon) $TIME(MINUTE) ;# amount that times must differ to be considered different, due to different clocks, delays in file system and network, ...
# groups: by suffix, by exact name (modulo compression wrapper), by regexp
# This is not intended to be a complete database -- add more and reassign in your ~/.sl.tcl startup file.
# are archives like dir (and sorted together)? both labelled collections
# tosort: maybe psd/ai/TODO in dev for artist?
# group names short so when used as title also separate groups by whitespace
# conflicts: .asf audio/video, .iso data/video, .xml doc/usually data, .raw and .bin can be anything
set GROUP {
special {byascii} {}
dir {title prefix by1} {}
build {byascii} { Makefile GNUmakefile build.xml -build.number configure INSTALL README }
app {bysuffix} { -.so -.a .jar .exe .dll -core }
dev {} { .c .cpp .cc .m -.h -.o .java -.class .scala .f
.tcl .sh .py -.pyc .pl .scpt .m4 .lua
.nib .y
-CVS -RCS -TAGS -tags .el -.elc }
A2 {title} { .dsk .do .po .2mg .2img .shk .sdk .sea .bsq .bxy .bny .bsc .dc }
WWW {} { .html .htm .shtml .php .php3 .ars }
aux {bysuffix} { .css .js .url .webloc robots.txt .json }
doc {prefix} { .txt .man .1 .3 .dox .chm .tex .bib .sty .dvi .texi .info .nfo .readme Index }
book {title} { .ps .pdf .djvu .epub .mobi .cbr .cbz }
document {title} { .indd .odt .doc .rtf .docx .ppt .pptx .xls .xlsx }
image {title nosfx prefix} { .jpg .jpeg .jp2 .png .gif .tiff .tif .dng .psd .xbm .xpm .pbm .pgm .ppm .ico .bmp .raw Thumbs.db }
vector {title} { .ai .svg .wmf .emf }
audio {title nosfx prefix} { .aac .mp3 .m4a .m4b .m4p .aif .aiff .snd .flac .ogg .oga .mid .wav .wma .ra .mod }
video {title nosfx prefix} { .mpg .mpeg .avi .mov .wmv .mkv .mp4 .m4v .flv .f4v .asf .ram .rm .rmvb .divx .vob .iso }
font {title nosfx prefix} { .pfb .pfa -.afm -.pfm .ttf .ttc .dfont .otf .otc .woff -fonts.dir -fonts.list -fonts.scale -encodings.dir }
data {} { .xml .plist .strings .data .dat .sfv .md5 .bin }
other {byascii} {}
archive {title prefix} { .zip .tar .tgz .xz .rar .sit .sitx .cpt .dmg }
dotfile {} {}
Mac {} { -.DS_Store "-Desktop DB" "-Desktop DF" }
ignore {} { .bak bkup .bkup .bup tmp .tmp -old .old -obsolete ignore }
}
if {([llength $GROUP]%3) != 0} {puts stderr "GROUP: some line missing field"; exit 1}
foreach {group flags entries} $GROUP {
set G2F($group) $flags
foreach x $entries {
if {"-" == [string index $x 0]} {set EQ([string range $x 1 end]) -$group
} else {set EQ($x) $group}
}
}
set tmp "(?i)README"
append tmp {|TODO$|notes|TOSORT}
append tmp {|Makefile$|configure$|build.xml} ;#|INSTALL
append tmp "|index.html?"; # HTML
set EQ(NOTABLE) $tmp
array set EQ {
WRAPPER {\.(gz|Z|bz2|uu|hqx)$}
AUTOBKUP {(.*?)(\.~\d+\.\d+\.)?~$}
DEV {(?i)notes|^todo|changelog}
DEVDIR {^lib$|^src|(^|[ _-])test|jar|dump}
MANDIR {/man/man[^/]+$} MANPAGE {^.+\.[1-9oln][^/]*$}
}
array set STYLE {
group ";01;35;4" file "" dir ";34" special ";36" link ";35"
notable ";7" autosearch ";36"
recent,file ";31" recent,dir ";31" relrec,file ";33" relrec,dir ";33"
relsize ";36"
warning ";1;01;31" pre ";36" post ""
log ";4" OFF ";0"
}
# 0 means off, else some value (maybe useful, not necessarily 1)
# filter - data - presentation - control - ls options
array set SWITCH {
version "v1.1.3 of February 19, 2012" site "http://www.PracticalThought.com/"
ignore 3 only 0
notable 1 autosearch {\W(urgent|password|pw|live)\W} relsize 5 relchange 10 relread 10 atime 0 vc 1
group 1 grouptitle 1 series 5 prefix 0 shorten 10 nosfx 0 title 0 maxcol 0 summary 2
startup "~/.sl.tcl" expando 2 log 0
F 1 1 0 B {~$|^#.*#$|^\.#}
}
set SWITCH(abschange) [expr $TIME(DAY)*2]
set SWITCH(TAP) [file exists "~/prj/Multivalent"] ;# experimental/aggressive
# i18n for words shown every time (but not for error messages)
foreach word {
file files directory directories ignored
second minute hour day month year
} { set I18N($word) $word }
foreach {key val} {
... '
pre0 " "
type-file "" type-directory "/" type-link "->" type-link-external "-->" type-special "_"
warn-link-broken "X" warn-empty "0" warn-single "1"
warn-box "!"
warn-link-hard-multiple "<-"
warn-bit-setUID "u" warn-bit-setGID "g" warn-bit-sticky "s" warn-world-writable "W"
warn-not-readable-by-user "r" warn-dir-not-searchable-by-user "x"
warn-vc-need "^" warn-vc-stale "v" warn-vc-other "v"
} { set I18N($key) $val }
# mount points of external drives (that might spin down and would be slow spin up)
set SWITCH(mounts) {/Volumes}
set SWITCH(encoding) [encoding system]
encoding system identity
# control
proc sl {dir {level 0}} {
global SWITCH
# filenames have different encodings: UTF-8, ISO8859-1, UTF-16 NFD (on OS X)
# we need both raw name for file stat and cooked name for display
encoding system $SWITCH(encoding); set cooked [glob -nocomplain -directory $dir -- "*" ".*"]
encoding system identity; set raw [glob -nocomplain -directory $dir -- "*" ".*"]
# leave encoding as identity for file stat
sl2 $dir $raw $cooked $level
}
proc sl2 {dir raw cooked level} {
if {[llength $raw]==0} return
global SWITCH GROUP G2F EQ STYLE LOG
set LOG {}; array set stats {series 0 pfx 0 pfxch 0}
set f [file normalize ~]; file stat $f home; set home(at) [string equal $f [file normalize $dir]]
# 1. build up data record for each file
log "[color collect log] [llength $raw]"
set fcnt 0; set dcnt 0; set igcnt 0; set igl {}
set totalsize 0; set totaldir 0; set dotcnt 0
set l {}
foreach f $raw show $cooked {
set tail [file tail $f]; if {"."==$tail || ".."==$tail} continue
set show [file tail $show]
file lstat $f stat ;# sometimes we care if it's a link and other times not
set type $stat(type); set typec ""
set size 0; set mtime $stat(mtime); set atime $stat(atime)
lassign [groupbyname $dir $show $type] group iglevel ts t sfx
set warning ""
if {[regexp $EQ(AUTOBKUP) $show all base] && [file join $dir $base] ni $cooked} {append warning [l10n warn-link-broken] ;# abandoned backup (emacs~, CVS.~<ver>.~)
} elseif {$SWITCH(ignore) >= $iglevel} {
if {$iglevel >= 3} {lappend igl $show}
if {$iglevel==2} {incr dotcnt} else {incr igcnt}
continue
}
set style ""; set pre " "; set post ""
# a. general
if {($stat(mode) & 04000) != 0} {append warning [l10n warn-bit-setUID]}
if {($stat(mode) & 02000) != 0} {append warning [l10n warn-bit-setGID]}
if {($stat(mode) & 01000) != 0} {append warning [l10n warn-bit-sticky]}
append post [peculiar $stat(mode) $type]
if {"link"==$type} {set typec [l10n type-link]; set style $STYLE(link)}
if {$SWITCH(TAP) && $home(at) && $stat(uid) != $home(uid) && $stat(nlink)==1} {append post " [color owner warning post]=" [uid2name $stat(uid)]} ;# sometimes root
# b. by type
if {"link"==$type && [external $dir $f]} {
# if symbolic link to another disk, don't stat b/c may be very slow (spin up drive or network)
# in UNIX can mount volumes anywhere just like directory, so go with OS X convention of /Volumes
set typec [l10n type-link-external]
# assume dir if not suffix? test on "[file link $f]"?
if {$sfx==""} {set style $STYLE(dir); set group dir; incr dcnt} else {incr fcnt}
} elseif {![file exists $f]} {
append warning [l10n warn-link-broken]
} elseif {[file isfile $f]} {
set typec [l10n type-file]
set style $STYLE(file)
if {[file executable $f]} {
if {"other"==$group} {set group app}
set warning "*$warning" ;#append post "*"
}
if {$type!="link"} {
if {![file readable $f]} {append warning [l10n warn-not-readable-by-user]}
set size $stat(size)
if {$size==0} {
set attrs [file attributes $f] ;# we don't use "file attributes $f -rsrclength" b/c error on non-Mac
if {[set x [lsearch -exact $attrs -rsrclength]] >= 0} {set size [lindex $attrs $x+1]}
}
incr totalsize $size
if {$size==0} {append warning [l10n warn-empty]}
if {$stat(nlink) > 1} {
append warning [l10n warn-link-hard-multiple] ;# or "$stat(nlink)", which is distinct from '0'-length file and '1' file in dir, but less mnemonic
#append post $stat(ino)
}
if {".nib"==$sfx && $size==232960} {set group A2} ;# special cases
if {".doc"==$sfx && $size < 22000} {set group doc}
}
incr fcnt
} elseif {[file isdirectory $f]} {
#set sfx ".directory" ?
set content {}
set fread [file readable $f]
if {$fread} {
set content [glob -nocomplain -directory $f -tails -- "*"]
# try to reset atime -- treat read above as metadata read just like stat()
set touchfmt [clock format $stat(atime) -format "%Y%m%d%H%M.%S"] ;# [[CC]YY]MMDDhhmm[.SS]
catch { exec touch -f -a -t $touchfmt $f } ;# changes ctime, but we value atime over ctime
}
lassign [classifydir $f $show $content] group size
set style $STYLE(dir)
if {"link"==$type} {
set size 0
} else {
set typec [l10n type-directory]
incr totaldir [expr $size]
if {!$fread} {append warning [l10n warn-not-readable-by-user]
} elseif {$size==0} {append warning [l10n warn-empty]
} elseif {$size==1 && [file exists "$f/Contents/Info.plist"]} { ;# "*.app" not reliable
#set group app -- in /Applications don't split app vs dir-w/app and other, just avoid warning due to single directory
} elseif {0 && $size==1} {set show [file join $show [lindex $content 0]] ;# inline singleton file, want to recurse here to a "proc maketuple {file}", probably make name too long as dirname + filename
} elseif {$size==1} {append warning [l10n warn-single]
} else {
append post $size
#if {$stat(nlink) < [llength $content]} {append warning "K"} ;# on UFS nlink = . + .. + #files, but on HFS+ external often wrong -- but in HFS+? no aux file for hard links?
}
if {($stat(mode) & 2) != 0} {append warning [l10n warn-world-writable]}
if {![file executable $f]} {append warning [l10n warn-dir-not-searchable-by-user]}
}
incr dcnt
} else {
set group "special"; set style $STYLE(special); set typec [l10n type-special]
incr fcnt
}
# c. appearance
set display $show ;# default to faithful so no surprises
set sortkey [normalizekey $t $sfx]
if {$SWITCH(title)} {
set display $t ;# "title" implies strip wrapper for every group
if {"title" in $G2F($group)} {set display [prettyname $display $type $group]}
# if chop suffix may get dups, which are zapped in lsort -unique
if {$SWITCH(nosfx) && "nosfx" in $G2F($group) && "file"==$type} {set sortkey [file rootname $sortkey]
} else {append display $sfx}
}
if {$SWITCH(F)} {append display $typec}
if {$SWITCH(notable) && [regexp $EQ(NOTABLE) $ts]} {append style $STYLE(notable)}
# 0 1 2 3 4 5 6 7 8 9 10 11 12 ... could use a struct here
lappend l [list $tail $sfx $type $group $sortkey $style $pre $display $warning $post $size $mtime $atime]
}
if {[llength $igl]>0} {log "ignored ($igl)"}
# comparison w/ls after ignore and before reindeer games
set maxlen 0; set cnt [expr $fcnt+$dcnt+[llength $igl]]
foreach tuple $l { set len [displaylen [lindex $tuple 0]]; if {$len > $maxlen} {set maxlen $len} }
global TERMINFO
set cols [expr $TERMINFO(width)/($maxlen+1+1)]; if {$cols==0} {set cols 1} ;# maxlen + 1 for trailing char + 1 for gap
log "cf ls -B $TERMINFO(width)/($maxlen+1+1) for $cnt = ${cols}x[iceil $cnt $cols]"
# 2. mark up data
log "[color mark log] [llength $l]"
if {$SWITCH(vc)} { foreach p [info commands "vc-*"] {set l [$p $dir $l]} }
set l [relative $l]
set datalen 0; set tuplelen [llength [lindex $l 0]]; set reported 0
foreach tuple $l {
if {[catch {set user [perfile $dir $tuple]} info]} {
if {!$reported} {puts stderr "$SWITCH(startup): $info"; set reported 1}
} elseif {[llength $user] == 0} { ;# NOT [lindex $user 2]=="ignore" b/c show orphaned ~ files
} elseif {[llength $user] != $tuplelen} {
if {!$reported} {puts stderr "$SWITCH(startup) returned bad list: $user"; set reported 1}
} elseif {$SWITCH(only) && ![distinctive $user]} {
} else {
#puts "[lindex $user 0] -> [lindex $user 4]"
lappend ga([lindex $user 3]) $user
incr datalen
}
}
if {$datalen == 0} return ;# possible after user processing and -only
# 3. display
# a. prepare display list: sort, groups
# lsort doesn't support a secondary key (we need group then dictionary within group), so custom sort
set l {}; set lastgroup "dir"; set gtitcnt 0
foreach {g flags ignore} $GROUP {
if {![info exists ga($g)]} continue
set gl $ga($g)
# "lsort command uses the merge-sort algorithm which is a stable sort" -- hooray!
set sortl [lsort -index 4 -dictionary -unique $gl] ;# only sort, or sets order for elements that are equal in subsequent sort
if {[set by [lsearch -glob -inline $flags "by*"]] != ""} {
if {"bysuffix"==$by} {set sortl [lsort -index 1 -ascii $sortl]
} else {set sortl [lsort -index 0 -command $by $sortl]}
}
# used to make series here, but better to treat series as a unit for proc relative
if {$SWITCH(series) && [llength $sortl] >= $SWITCH(series)} {lassign [series $sortl] sortl cnt; incr stats(series) $cnt} ;# series before prefix
if {$SWITCH(prefix) && "prefix" in $flags} {lassign [prefix $sortl] sortl cnt1 cnt2; incr stats(pfx) $cnt1; incr stats(pfxch) $cnt2}
if {$SWITCH(grouptitle) && $g != $lastgroup} {
lappend l [list "" "" "GROUP" "" "" $STYLE(group) " " $g "" "" 0 0 0] ;# "$name ([llength $ga($g)])" like dir? didn't like it
set lastgroup $g
incr gtitcnt
}
set l [concat $l $sortl]
}
if {$stats(series) > 0} {log "series -$stats(series)"}
if {$stats(pfx) > 0} {log "prefix $stats(pfx) ($stats(pfxch) chars)"}
if {!$SWITCH(group)} {set l [lsort -index 4 -dictionary $l]}
# b. display: table, summary line, log
log "[color display log] [llength $l]"
column $l $gtitcnt
if {$SWITCH(summary) && $datalen >= $SWITCH(summary)} {
puts -nonewline " [plural $fcnt file files]"
if {$fcnt>0} {puts -nonewline " ([kmg $totalsize OFF])"}
if {$dotcnt > 0} {puts -nonewline " + [plural $dotcnt dotfile dotfiles [color . warning]]"}
if {$igcnt>0} {puts -nonewline " + [plural $igcnt ignored ignored]"}
if {$dcnt>0} {puts -nonewline ", [plural $dcnt directory directories] ([plural $totaldir file files])"}
#if {$dir!="/"} {puts -nonewline ", .. ([plural [llength [glob $dir/../*]] file files])"}
puts ""
}
if {$SWITCH(log) && [llength $LOG] > 0} {puts "log: [join $LOG {, }]"}
if {$SWITCH(expando) && $fcnt<=$SWITCH(expando) && $dcnt==1 && $level < 10} {
foreach tuple $l {
if {"directory"==[lindex $tuple 2] && [lindex $tuple 10]>0} { ;# && [lindex $tuple 10] < ? ... this is in place of original anemic dir
set subdir [lindex $tuple 0]
puts [format "\nautoexpand [color %s/ dir]:" $subdir]
sl [file join $dir $subdir] [expr $level+1]
break
}
}
}
}
#
# organization: grouping
#
proc groupbyname {dir tsw type} {
global EQ SWITCH
# distinguish types from wrappers, so doc.txt and photo.jpg are different groups, but doc.txt and doc2.txt.gz are same group
#if [catch { set tail [file tail $f] }] {return "other"} ;# "home.insightbb.com/~fourcolorheros" as a path
if {[regexp -nocase $EQ(WRAPPER) $tsw]} {set ts [file rootname $tsw]} else {set ts $tsw}
if {"file"==$type && [set t [file rootname $ts]]!=""} {set sfx [string tolower [file extension $ts]]} else {set t $ts; set sfx ""}
if {[info exists EQ($ts)]} {set g $EQ($ts) ;# can't beat exact
} elseif {[regexp $SWITCH(B) $ts]} {set g ignore ;# regex take precedence over suffix since reclassifying to more specific, ignore first
} elseif {"."==[string index $ts 0]} {set g dotfile
} elseif {[regexp $EQ(DEV) $ts] && ($sfx=="" || $sfx==".txt")} {set g dev
} elseif {[regexp $EQ(MANDIR) $dir] && [regexp $EQ(MANPAGE) $ts]} {set g doc
} elseif {[info exists EQ($sfx)]} {set g $EQ($sfx)
} else {set g other}
if {"-"==[string index $g 0]} { set g [string range $g 1 end]; set iglevel 3
} elseif {"dotfile" == $g} { set iglevel 2
} elseif {"ignore" == $g} { set iglevel 1
} else { set iglevel 4 }
return [list $g $iglevel $ts $t $sfx]
}
proc external {dir f} {
global SWITCH
set link [file link $f]
if {[string equal -length [string length $dir] $dir $link]} { return 0 }
foreach d $SWITCH(mounts) {
if {[string equal -length [string length $d] $d $link]} { return 1 }
}
return 0
}
proc classifydir {f show l} {
global EQ GROUP SWITCH
set MAXEXT [string length ".torrent"]
# 1. by content
# a. counts
foreach {g ignore1 ignore2} $GROUP {set cc($g) 0}
set llen 0; set softignore 0
foreach c $l {
lassign [groupbyname $f $c "file"] g iglevel ts t sfx
if {$iglevel <= 2} continue elseif {$iglevel==3} {incr softignore}
if {$g=="other"} { ;# guess at dir w/o stat (which would be slow on sometimes 1000s of files)
set extlen [string length $sfx]
if {$extlen==0 || $extlen > $MAXEXT} {set g dir}
}
incr cc($g); incr llen
}
# b. analyze
set known [expr $llen - $cc(other)] ;# within types that we can identify (though id by suffix is weak)
set max 0; set maxg "dir"
unset cc(other) cc(A2) cc(ignore)
foreach g [array names cc] {
set len $cc($g)
if {$len > $max} {set max $len; set maxg $g}
}
set relen 0; foreach c {video audio image WWW} {incr relen $cc($c)}
# c. reclassify
set g "dir"
#puts "[array names cc] $cc(video) + $cc(audio) + $cc(image) + $cc(WWW) > $llen/2"
if {"."==[string index $show 0]} {set g dotfile
} elseif {[lsearch -nocase -glob $l "VIDEO_TS*"] >= 0} {set g video ;# VIDEO_TS/ or VIDEO_TS.VOB
} elseif {$cc(dir) >= 3} {
# hierarchy
} elseif {$relen>0 && ($relen >= $llen/2 || $llen<=4)} { ;# media special case
if {$cc(video) > 0} {set g video
} elseif {$cc(audio) > $cc(image)} {set g audio
} elseif {$cc(WWW) >= 2 || ($cc(WWW)==1 && $relen<=2) || ($cc(WWW)>=1 && [lsearch -nocase -glob $l "index.htm*"]>=0)} {
#set g WWW -- keep as a group so not image/, but don't reclassify b/c gets mixed in with other .html in site
} else {set g image}
} elseif {$max >= [expr $known/2]} { ;# other groups
if {$maxg!="WWW"} {set g $maxg}
}
# 2. by name
if {[regexp $EQ(DEVDIR) $show]} {set g dev}
# Xelseif {"doc"==$show || "man"==$show} {set g doc} => by content
#puts "$show -> $g $cc($g) of $known/$llen"
set size [expr $llen-$softignore]; if {$SWITCH(TAP) && $g!="dir" && 0 < $cc($g)&&$cc($g) < $size} {set size "$cc($g)+[expr $size-$cc($g)]"}
return [list $g $size]
}
proc normalizekey {t sfx} {
# Xset s [string tolower $s] => no, some sorts case sensitive
set s $t
if {[regexp {^(\.)} $s all pfx]} {set s [string range $s [string length $pfx] end]} {set pfx ""}
regsub -all {#(\d)} $s {\1} s; ;# "#<number>" vs plain "<number>"
regsub -all {(\D)(\d+)} $s {\1~\2} s ;# if compare something w/number vs something without put number afterward, because first movie in series not given a number
regsub -all {[-\. _\t]+} $s { } s ;# normalize word separators into single space -- maybe all punctuation?
regsub -all -nocase {(^| )(the|a|an) } $s {\1} s ;# "a" and "an" may be too aggressive, but try it and let experience guide
if {$s==""} {set s $t} else {set s "$pfx$s$sfx"} ;# oops, we were too aggressive
#puts "$t -> $s"
return $s
}
#
# data: relatively recent, relatively large, version control
#
proc relative {l} {
global STYLE TIME SWITCH
# recent, both absolute and relative
set abscutoff [expr $TIME(now)-$SWITCH(abschange)]
set sizel {}; set mtimel {}; set atimel {}
foreach tuple $l {
lappend sizel [expr [lindex $tuple 10]] ;# yeah compares sizes of files and dirs, but works out OK
lappend mtimel [lindex $tuple 11]
if {[lindex $tuple 2]!="directory"} {lappend atimel [lindex $tuple 12]}
}
log "NOW = $TIME(now)"
lassign [cutoff relsize $sizel 1] cutoffsize repz
lassign [cutoff relchange $mtimel [expr 5*$TIME(MINUTE)]] cutoffm repm ;# e.g., time to rip a CD
lassign [cutoff relread $atimel [expr 5*$TIME(MINUTE)]] cutoffa repa
set l2 {}
foreach tuple $l {
lassign $tuple tail sfx type group sortkey style pre display warning post size mtime atime; set size [expr $size]
#if {$size > $cutoffsize} {set style "[lindex $tuple 5];1"}
#if {$mtime >= $abscutoff} {set pre " " ;# # other chars like "*" and '^" blend in too much, colorize too much
#} elseif {$mtime > $cutoffm} {set pre "."} ;# ">" so run of same across border ignores all (prefer few to too many)
# bold visually stronger than indent and recent more important than largest, so bold on recent... but bold unreliable?
# often recent also notable (index.html), bold dir blend in with groups
set sub [expr {$type=="directory"?"dir":"file"}]
if {$SWITCH(relsize) && ($size > $cutoffsize || ($size==$cutoffsize && $repz))} {
set pre " " ;# indent, could also outdent if single space char
if {"file"==$type} {append post " " [kmg $size post]} ;# dir already has size
set repz 0 ;# choose only one as the representative
}
if {$SWITCH(abschange) && $mtime >= $abscutoff} {
append style $STYLE(recent,$sub)
if {$mtime > $cutoffm || $TIME(now)-$mtime < $TIME(HOUR)} {append post " <" [ago $mtime]; set repm 0}
} elseif {$SWITCH(relchange) && ($mtime > $cutoffm || ($mtime==$cutoffm && $repm))} {
append style $STYLE(relrec,$sub); append post " <" [ago $mtime]; set repm 0
}
# can't do absolute (last day, say) due to OS X Spotlight, access since last mod, not dir b/c we do a glob our own damn selves
# Spotlight: no benefit b/c continuously touching and not resetting, but doesn't cause bad results b/c touches everything so no few most recent and if <=4 files we don't mark anyhow
if {"directory"==$type} {
# don't do dirs -- always being touched
} elseif {$SWITCH(atime) > 0} { ;# if explicitly turned on absolute, don't confuse with relative
if {$TIME(now) - $atime <= $SWITCH(atime)} {
set pre "->[string range $pre 2 end]"; append post " -" [ago $atime]; set repa 0 ;# "=>" so different than relative? no, won't have both kinds at the same time, string range in case also relsize
}
} elseif {$SWITCH(relread) && ($atime > $cutoffa || ($atime==$cutoffa && $repa)) && $atime > $mtime + $TIME(MINUTE)} {
set pre "->[string range $pre 2 end]"; append post " -" [ago $atime]; set repa 0
}
lappend l2 [list $tail $sfx $type $group $sortkey $style $pre $display $warning $post $size $mtime $atime]
}
return $l2
}
proc cutoff {what l by} {
global SWITCH
set pct $SWITCH($what)
set llen [llength $l]; if {$llen==0 || $pct==0} return elseif {$llen==1} {return [list [lindex $l 0] 1]}
set l [lsort -command bybignum -decreasing $l]; set max [lindex $l 0]
set cut [expr (($llen*$pct)/100)+1]; if {$cut>$pct} {set cut $pct}
set val [lindex $l $cut]; set rep 0
if {$llen > 4} { ;# have to differ by a meaningful amount -- if all downloaded within a couple minutes a year ago, that's just random
set median [expr $llen/2]
set beat [expr [lindex $l $median] + $by]
if {$val < $beat} {set val $beat}
}
if {$max <= $val} {
set val $max
if {!$SWITCH(only)} {set rep 1; log "$what rep=$val"} ;# single representative value to characterize, but if -only prefer nothing
} else {log "$what > $val @ $cut"}
return [list $val $rep]
}
proc peculiar {mode type} {
# 1. anything peculiar?
# zots
if {($mode & 0777) == 0} { return [color "---------" warning post] }
set h 0
set powner [expr ($mode>>6)&0x7]; set pgroup [expr ($mode>>3)&0x7]; set pothers [expr $mode&0x7]
# owner/w/x but no r
if {($powner&4)==0} {set h [expr $h|(4<<6)]}
if {(1 <= $pgroup&&$pgroup <= 3)} {set h [expr $h|(4<<3)]}
if {(1 <= $pothers&&$pothers <= 3)} {set h [expr $h|4]}
# more important but lower perm
set p [expr $powner & $pgroup]; if {$p != $pgroup} {set h [expr $h|(($pgroup - $p)<<6)]}
set p [expr $powner & $pothers]; if {$p != $pothers} {set h [expr $h|(($pothers - $p)<<6)]}
set p [expr $pgroup & $pothers]; if {$p != $pothers} {set h [expr $h|(($pothers - $p)<<3)]}
# directory: r,w but not x
if {"directory"==$type} {
if {($powner&6)!=0 && ($powner&1)==0} {set h [expr $h|(1<<6)]}
if {($pgroup&6)!=0 && ($pgroup&1)==0} {set h [expr $h|(1<<3)]}
if {($pothers&6)!=0 && ($pothers&1)==0} {set h [expr $h|1]}
}
if {$h==0} {return ""}
# 2. if so, then highlight that bit
set post " "; set rwx [perm $mode]
for {set bit 8} {$bit>=0} {incr bit -1} {
set c [string index $rwx [expr 8-$bit]]
if {((1<<$bit)&$h) != 0} {append post [color $c warning post]
} else {append post $c}
}
return $post
}
# version control
proc vc-rcs {dir l} {
set rep "$dir/RCS"; if {![file readable $rep]} {return $l}
set l2 {}
foreach tuple $l {
lassign $tuple tail sfx type group sortkey style pre display warning post size mtime atime
set fv [file join $rep "$tail,v"]
if {[file exists $fv] && [file mtime $fv] < $mtime} {append warning [l10n warn-vc-need]}
# RCS repository is local, so theoretically can't have stale local copy
lappend l2 [list $tail $sfx $type $group $sortkey $style $pre $display $warning $post $size $mtime $atime]
}
return $l2
}
proc vc-cvs {dir l} {
global TIME
set cvs "$dir/CVS"; if {![file readable $cvs] || ![file readable $cvs/Root]} {return $l}
set fid [open "$cvs/Root"]; set root [read -nonewline $fid]; close $fid
set fid [open "$cvs/Repository"]; set rep [read -nonewline $fid]; close $fid
set fid [open "$cvs/Entries"]; set entries [read $fid]; close $fid
set data {}
foreach line [split $entries "\n"] {
lassign [split $line "/"] pre name ver date options tagdate
lappend data [list $name $ver $date]
}
set rep [file join $root $rep]
if {![file exists $rep]} {puts [color "can't find CVS repository: $rep" warning]} ;# maybe even blink
set l2 {}
foreach tuple $l {
lassign $tuple tail sfx type group sortkey style pre display warning post size mtime atime
set rec [lsearch -exact -index 0 -inline $data $tail]
if {$rec==""} {
# not under version control
} elseif {[regexp {^[-0]} [set civer [lindex $rec 1]]]} {
# locally added (version 0) or removed (negative version number), not yet checked in
append warning [l10n warn-vc-need]
} else {
# repository updated, local stale
set citime [clock scan [lindex $rec 2] -gmt true]
if {![file exists [set fv [file join $rep "$tail,v"]]]} {
#append warning [l10n warn-link-broken] -- maybe not local
} elseif {[file mtime $fv] > $citime+$TIME(epsilon)} { ;# preliminary check to reduce #files that have to read
set fid [open $fv]; set head [read $fid 4096]; close $fid
if {[regexp {head\s[(\d\.)]+;} all repver] && $civer != $repver} {
append warning [l10n warn-vc-stale]
}
}
# local changed since last
if {$mtime > $citime+$TIME(epsilon)} {
append warning [l10n warn-vc-need]
}
}
lappend l2 [list $tail $sfx $type $group $sortkey $style $pre $display $warning $post $size $mtime $atime]
}
return $l2
}
#
# display: filter, series, prefix, layout
#
proc distinctive {tuple} {
global STYLE
lassign $tuple tail sfx type group sortkey style pre display warning post size mtime atime
set show 0
if {$type=="file"} {
if {$style!=$STYLE(file) || $pre!=" " || ($warning!="" && $warning!="*" && $warning!="*<-") || $post!=""} {set show 1}
} elseif {$type=="directory"} {
if {$style!=$STYLE(dir) || $pre!=" " || ($warning!="" && $warning!="1") || [llength $post]>1} {set show 1}
}
return $show
}
proc prettyname {d type group} {
# SWITCH(title) is not on by default because you have type the exact name in,
# but it's OK if you use file completion and are aware that the filename display may not be exactly the same.
regsub -all {([a-z])([A-Z])} $d {\1 \2} d ;# camelCase -> camel Case
regsub -all {[\._ ]+} $d { } d
return $d
}
# requires list sorted in dictionary order
proc series {l} {
global SWITCH
set KEY 0 ;# 0=tail, 4=sortkey, 7=displayname
set RX_RELZ { [\.\d]{1,4}[BKMGTPEZY]}
set seriesl {}; set cnt 0
for {set i 0; set imax [llength $l]} {$i<$imax} {} {
set tuple [lindex $l $i]
set relz 0
for {set j $i} {$j<$imax} {incr j} {
set tuple2 [lindex $l $j]
if {[lindex $tuple2 2]=="directory"} {break ;# dir already kind of a series
} elseif {$j==$i} {
} elseif {![serieseq [lindex $t $KEY] [lindex $tuple2 $KEY]]} {break
} elseif {[lindex $tuple2 8] != ""} {break ;# keep warnings
} elseif {[set post2 [lindex $tuple2 9]] != ""} {
if {[regexp $RX_RELZ $post2 all] && [string length $post2]==[string length $all]} {incr relz} else break
}
set t $tuple2 ;# progressive
}
set slen [expr $j-$i]
if {$slen >= 3} {
set post [lindex $tuple 9]
if {$relz && ![regexp $RX_RELZ $post]} {append post " " [kmg [lindex $tuple 10] post]} ;# maybe also do this if length of series >100 or would qualify by relsize percentage (set zlen [expr 100/$SWITCH(relsize)]), size of first tuple is representative but maybe instead show largest in series or sum
append post "..." $slen
lset tuple 9 $post
set i $j ;# j at first mismatch, which is next start
incr cnt [expr $slen-1]
} else {incr i}
lappend seriesl $tuple
}
return [list $seriesl $cnt]
}
proc serieseq {f1 f2} {
set len [string length $f1]
if {[string length $f2] != $len} {return 0}
set i 0
# if [string length [file rootname]] >= 10 then assume must be a common prefix
if {$len >= 6+4} { ;# [string length "999999"]==6 + 4 for suffix (though some groups have no suffix)
for {} {$i < 4} {incr i} {
if {[string index $f1 $i] != [string index $f2 $i]} { return 0 }
}
}
set alphaseries 0
for {} {$i<$len} {incr i} {
set c1 [string index $f1 $i]; set c2 [string index $f2 $i]
if {$c1==$c2} {
} elseif {[string is integer $c1] && [string is integer $c2]} {
} elseif {$alphaseries} {break
} elseif {[string is alpha $c1] && [string is alpha $c2]} {
#scan $c1 "%c" v1; scan $c2 "%c" v2
#X if {$v1+1==$v2} {set alphaseries 1} else {return 0} => too strict
set alphaseries 1
} elseif {[string is integer $c1] && [string is alpha $c2]} { ;# 0..9 over to a..z
set alphaseries 1
} else break
}
return [expr $i==$len]
}
# requires list in display order
proc prefix {l} {
global SWITCH
set l2 {}; set lastd ""; set lastlen 0
set cnt 0; set cntch 0
foreach tuple $l {
set d [lindex $tuple 7]; set len [string length $d]
set pfx 0
set i 0; set imax [expr $lastlen<$len?$lastlen:$len]
for {set lastc ""} {$i<$imax} {incr i; set lastc $c2} {
set c1 [string index $lastd $i]; set c2 [string index $d $i]
# breakpoints -- computed on text to be elided not on base
if {$c2==" "} {set pfx [expr $i+1] ;# not A-Za-z0-9
} elseif {[string is punct $c2] || $c2=="\u001b"} {set pfx $i ;# not A-Za-z0-9
} elseif {$lastc==""} {
} elseif {[string is lower $lastc] && [string is upper $c2]} {set pfx $i ;# camelCase
} elseif {[string is alpha $lastc] && [string is digit $c2]} {set pfx $i ;# letter->number
}
# elseif >=3 chars x >= 4 names ?
if {$c1 != $c2} break
}
if {$i==$imax && ![string is digit $lastc]} {set pfx $i}
if {$pfx >= $SWITCH(prefix)} {
lset tuple 7 "[format {%*s} $pfx { }][string range $d $pfx end]" ;# $pfx-1 spaces and ~ not appealing
incr cnt; incr cntch $pfx
}
lappend l2 $tuple
set lastd $d; set lastlen $len
}
return [list $l2 $cnt $cntch]
}
# sorting comparators
proc byascii {f1 f2} { return [string compare $f1 $f2] }
proc by1 {f1 f2} { return [string compare -length 1 $f1 $f2] }
# would like to use lsort -integer but handle a file size larger than 4GB on 32-bit machines, (return non-bignum result!)
proc bybignum {n1 n2} { return [expr {$n1<$n2?-1:[expr $n1==$n2?0:1]}] }
# "[l10n file]" vs "$l10n(file)" -- same number of chars
proc l10n {word} {
global I18N
if {[info exists I18N($word)]} {set word $I18N($word)}
return $word
}
set COLSEP 1 ;# min space between columns, but effectively +2=3 from 'pre', almost always appears to be much more due to different name lengths and markings. ls is 1
set NAMEMIN 40 ;# so 2 cols on 80-col screen
proc column {l gtitcnt} {
global TERMINFO NAMEMIN COLSEP SWITCH
# 1. compute widths needed by tuples, with max that allows >=COLSMIN
set llen [llength $l]
set width [expr $TERMINFO(width)-1] ;# right margin (get left margin for free with pre==" ")
if {$SWITCH(1)} {set width 1}
set colsmin [expr $width / $NAMEMIN]
if {$colsmin <= 1 || !$SWITCH(shorten) || $llen < $SWITCH(shorten)} {set namemax 1000000 ;# if few to show give them what they want
} else {set namemax [expr ($width - $COLSEP * ($colsmin-1)) / $colsmin]}
set ll {} ;# "ll" = list + lengths
set maxlen 0
foreach tuple $l {
lassign $tuple tail sfx type group sortkey style pre display warning post size mtime atime
set len [expr [displaylen $display]+[string length $pre]+[displaylen $post]+[string length $warning]]
if {$len > $maxlen} {set maxlen $len}
if {$len > $namemax} {set lenx $namemax} {set lenx $len}
lappend ll [list $tail $sfx $type $group $sortkey $style $pre $display $warning $post $size $mtime $atime $len $lenx]
}
if {$maxlen > $namemax} {log "|cell| $maxlen->$namemax"}
set maxw [expr $maxlen<$namemax?$maxlen:$namemax]; set colsuni [expr $width/($maxw+$COLSEP)]; if {$colsuni==0} {set colsuni 1}
log "uni $width/$maxw=${colsuni}x[iceil $llen $colsuni]"
# 2. compute col x row, and cols widths
# a. max out columns
set rows $llen ;# possible that tail > screen width, in which case wraparound
for {set c $colsuni} {1} {set c [iceil $llen [expr $r-1]]} {
set r [iceil $llen $c]
lassign [tailor $ll 0 $llen $r] sumx wxl
if {$sumx > $width} { log "X[llength $wxl]x$r = $sumx"; break }
set rows $r; if {$r==1} break
}
# b. aesthetic refinements
if {$rows==1 && $gtitcnt>=1} {incr rows; log "rows 1->2 for [plural $gtitcnt title titles]"}
lassign [bump $ll $rows $width] ll1 bot1; set cols1 [iceil [llength $ll1] $rows]
log "tailored ${cols1}x$rows bot=$bot1"
if {$SWITCH(maxcol) || $rows == 1 || $cols1 == 1} { ;# single row quite readable so keep, need a col to take away or bump into
set ll $ll1
} else { ;# if title at bottom then bump, swap +1 row for -1 col (easier to read, but don't drastically reshape)
set rows2 [expr $rows+1]; lassign [bump $ll $rows2 $width] ll2 bot2; set cols2 [iceil [llength $ll2] $rows2]
if {$bot2 < $bot1} {set ll $ll2; incr rows; log "row+1 ${cols2}x$rows2 (< bot=$bot1->$bot2)"
} elseif {$bot2==$bot1 && $cols2+1==$cols1 && $cols2>=4} {set ll $ll2; incr rows; log "row+1 ${cols2}x$rows2 (< cols)"
} else {set ll $ll1; log "X${cols2}x[expr $rows2] bot=$bot2"}
}
# if extra space, give to maxed out columns (only -- don't space out columns across screen like ls)
set llen [llength $ll]; lassign [tailor $ll 0 $llen $rows] sumx wxl wl; set cols [llength $wxl] ;# final #cols based on #rows
set slack [expr $width - $sumx]; set slack0 $slack
for {set ate 1} {$ate} {} {
set ate 0
for {set i 0} {$i<$cols && $slack>0} {incr i} {
if {[set x [lindex $wxl $i]] < [lindex $wl $i]} {lset wxl $i [expr $x+1]; incr slack -1; incr ate}
}
}
if {$slack < $slack0} {log "+[expr $slack0-$slack] widths"}
# if extra space, space out columns a little more (but not a lot)
set gut [expr $cols-1]
if {$slack >= $gut} { log "+1*$gut gutter" ;# just +1 space, not until exhaust slack
for {set i 0} {$i<$gut} {incr i} {
lset wxl $i [expr [lindex $wxl $i]+1]
}
}
# if prefix on and all names in column have prefix, then close up gap
set pfxl {}
for {set i 0; set j 0; set pfx 1000} {$i<$llen} {incr i} {
if {![string is space -failindex p [lindex $ll $i 7]] && $p < $pfx} {set pfx $p}
if {$j+1==$rows || $i+1==$llen} {lappend pfxl $pfx; set j 0; set pfx 1000} else {incr j}
}
#puts "col pfx: $pfxl for ${cols}x$rows <= $llen"
# 3. display
if {$SWITCH(1)} {set wxl [list $namemax]}
set shortened 0
for {set i 0} {$i<$rows} {incr i} {
for {set j 0; set n $i} {$n<$llen} {incr j; incr n $rows} {
set tuple [lindex $ll $n]
set w [lindex $wxl $j]; set hasnextcol [expr $n+$rows < $llen] ;# stricter than $j+1<$cols
if {[llength $tuple]==0} {
set gap [expr $w-$COLSEP]
} else {
lassign $tuple tail sfx type group sortkey style pre display warning post size mtime atime len lenx
puts -nonewline [color $pre pre]
if {$style!=""} {puts -nonewline [colorcode $style]}
set availw $w
if {$hasnextcol} {incr availw -$COLSEP} elseif {$j+1<$cols} {incr availw [lindex $wxl [expr $j+1]]} ;# spill into next column
if {$availw >= $len} {set show $display; set gap [expr $availw-$len]
} else {
incr availw -[expr [string length $pre]+[displaylen $post]+[string length $warning]]
set show [shorten $display $availw]; set gap [expr $availw-[displaylen $show]]; incr shortened
}
# have to do autosearch at the last second, possible that proc shorten stripped text that would have matched
set auto $SWITCH(autosearch); if {$auto!="" && $auto!=0 && [regexp -nocase -indices $auto $show num]} {
lassign $num n1 n2
#puts "$show: $num -> $n1 $n2"
set a [string range $show 0 $n1-1]; set b [string range $show $n1 $n2]; set c [string range $show $n2+1 end]
set show "$a[color $b autosearch $style]$c"
}
#puts -nonewline [string range $show [lindex $pfxl $j] end]
puts -nonewline $show
if {$style!=""} {puts -nonewline [colorcode OFF]}
if {$warning!=""} {puts -nonewline [color $warning warning]}
puts -nonewline [color $post post]
}
if {$hasnextcol} {puts -nonewline [format "%-*s" [expr $gap+$COLSEP] " "]}
}
puts ""
}
if {$shortened>0} {log "$shortened names shortened"}
}
proc tailor {l i llen rows} {
log "tailor"
global COLSEP
# width of cols = width of widest cell
set sumx 0; set wl {}; set wxl {}
for {} {$i<$llen} {incr i $rows} {
set max 0; set maxx 0
for {set j $i; set jmax [expr $i+$rows]} {$j<$jmax && $j<$llen} {incr j} {
set len [lindex $l $j 13]; set lenx [lindex $l $j 14]
if {$len > $max} {set max $len}
if {$lenx > $maxx} {set maxx $lenx}
}
if {$i+$rows < $llen} {incr max $COLSEP; incr maxx $COLSEP}
incr sumx $maxx; lappend wl $max; lappend wxl $maxx
}
# X if have extra space, give to maxed out columns => premature. Maybe could bump title, but can't b/c allowed to expand.
return [list $sumx $wxl $wl] ;# #cols == [llength $wl]
}
# if group title at bottom of column, bump to next column, if we can (free cell, widths OK)
proc bump {ll rows width} {
set llen [llength $ll]; set bot 0
for {set i [expr $rows-1]; set imax [expr $rows>1?$llen:0]} {$i<$imax} {incr i $rows} {
if {"GROUP"==[lindex $ll $i 2]} {incr bot}
}
if {$bot==0} {return [list $ll $bot]}
lassign [tailor $ll 0 $llen $rows] sumx wxl
set bumpl {}; set botbump 0
for {set i 0; set c 0; set r 0; set left 0} {$i<$llen} {incr i} {
set tuple [lindex $ll $i]
if {$r==0} {incr left [lindex $wxl $c]}
if {$r+1==$rows && "GROUP"==[lindex $tuple 2]} {
# bump?
lassign [tailor $ll $i $llen $rows] sumx wxl2
if {$left + $sumx <= $width} {
lappend bumpl {}
set wxl $wxl2; set c 0; set r 0; incr left [lindex $wxl 0]
} else {incr botbump} ;# puts "can't: [lindex $tuple 0] $left + $sumx !<= $width"
}
lappend bumpl $tuple
if {$r+1 < $rows} {incr r} else {incr c; set r 0}
}
# possible that bumping gives more titles at bottom
# (unimplmented: edge case where first bumps OK then if stop would win)
if {$botbump < $bot} {
log "bot $bot->$botbump after bump @ rows=$rows"
set ll $bumpl; set bot $botbump
}
return [list $ll $bot]
}
#
# generally useful utility procs: color, pretty print (size, time, shorten text)
#
# (color info gleaned from GNU ls.c)
# 0=end, 1=bold or brighter, 2=darker, 3=italics, 4=underline, 5=slowly blink, 6=rapidly blink, 7=rev, 8=hidden, 9=crossout
# 3x=foreground, 4x=background, where x is 0=black, 1=red, 2=green, 3=yellow, 4=blue, 5=magenta, 6=cyan, 7=white
set COLORIZE 1; #if {![info exists env(TERM)] || ![string match "*color*" $env(TERM)]} {set colorize 0} -- assume color
proc color {txt {style ""} {context OFF}} {
if {[string is space $txt]} {return $txt}
set on [colorcode $style]; if {$on==""} {return $txt}
set off ""; if {$context!="OFF"} {set off [colorcode OFF]}
set reset [colorcode $context]
return "$on$txt$off$reset"
}