-
Notifications
You must be signed in to change notification settings - Fork 0
/
file-dir.lisp
2328 lines (2186 loc) · 106 KB
/
file-dir.lisp
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
;;; :FILE mon-systems/file-dir.lisp
;;; ==============================
;;; ==============================
;;
;; Following is the Lord Voldemort of CL forms:
;; It is dangerous code that one should _never_ be evaluated:
;; (m@pc@r (lambda (x) (ignore-errors (delete-file x)))
;; (directory "/**/*.*")) ; <-- IOW don't evaluate that EVER!
;;
;; For more details google: <[email protected]>
;;
;; #lisp 2011-06-02
;; <pjb> mon_key: notice that it doesn't delete everything on your system.
;; Actually, it doesn't delete anything of importance, only all the files
;; owned by the user. (But don't run it as root). It's the same as rm -rf
;; /, which is rather benign again, unless you run it as root.
;; <pjb> mon_key: to the contrary of, eg. FORMAT C:, which did delete
;; everything, since there was no notion of user and file protection on
;; MS-DOS.
;;
;;; ==============================
;;; ==============================
;; #lisp 2011-03-01
;; re removing directories without following symbolinks:
;; <nikodemus> (cffi:foreign-funcall "system" :string (format nil "rm -rf ~A" dir) :int) ; the dirty option [15:18]
;; <lichtblau> yay, from symlink problem to space-in-filename problem
;;; ==============================
;;; ==============================
;;
;; :TODO
;; :EMACS-LISP-COMPAT `symbol-file', `locate-library', `process-lines'
;;
;;; ==============================
(in-package #:mon)
(defun file-name-directory (filename)
(directory-namestring filename))
;; `namestring-directory' and `namestring-file' are convenience functions for slime completion
(defun namestring-directory (pathname)
(directory-namestring pathname))
;;
(defun namestring-file (pathname)
(file-namestring pathname))
(defun file-truename (filename)
(truename filename))
(defun file-directory-p (filename)
(and (probe-file filename)
(equal (make-pathname :directory (pathname-directory (truename filename)))
(pathname (truename filename)))))
(defun directory-file-name (dirname)
(let ((this-dir (pathname-directory dirname))
new-dir
as-fname)
(setf new-dir (reverse this-dir))
(setf as-fname (pop new-dir))
(setf new-dir (reverse new-dir))
(make-pathname :name as-fname :directory new-dir)))
(defun file-write-date-timestring (pathname-or-namestring
&key (timestring-format
"~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d"
;; yr mon day hr min sec
))
(declare (type string timestring-format))
#-:sbcl (check-type timestring-format string)
(multiple-value-bind (sec min hr day mon yr wd dp zn) (decode-universal-time (file-write-date pathname-or-namestring))
(declare (ignore wd dp zn))
(format nil timestring-format yr mon day hr min sec)))
;; set-file-write-date
;; (+ SB-IMPL::UNIX-TO-UNIVERSAL-TIME
;; (sb-posix:stat-mtime (sb-posix:stat pathname-or-namestring)))
;;
;; (eql (sb-impl::truncate-to-unix-range (get-universal-time))
;; (- (get-universal-time) SB-IMPL::UNIX-TO-UNIVERSAL-TIME))
;;
;; (let ((unix-time-now (sb-impl::truncate-to-unix-range (get-universal-time))))
;; (set-file-write-date <FILE> unix-time-now unix-time-now))
;; *features*
;; (featurep 'SB-POSIX)
#+:sbcl
(defun set-file-write-date (pathname-or-namestring access-time modification-time)
(declare (pathname-or-namestring pathname-or-namestring)
(unsigned-byte access-time modification-time))
(unless (probe-file pathname-or-namestring)
(error ":FUNCTION `set-file-write-date' -- arg PATHNAME-OR-NAMESTRING did not satisfy `cl:probe-file'~% got: ~S"
pathname-or-namestring))
(values
(zerop (sb-posix:utime (sb-ext:native-namestring pathname-or-namestring) access-time modification-time))
(file-write-date pathname-or-namestring)))
;;
#+:sbcl
(defun set-file-write-date-using-file (target-pathname-or-namestring source-pathname-or-namestring)
(declare (pathname-or-namestring target-pathname-or-namestring source-pathname-or-namestring))
(unless (probe-file source-pathname-or-namestring)
(error ":FUNCTION `set-file-write-date' -- arg SOURCE-PATHNAME-OR-NAMESTRING did not satisfy `cl:probe-file'~% got: ~S"
source-pathname-or-namestring))
(let* ((source-stat (sb-posix:stat (sb-ext:native-namestring source-pathname-or-namestring)))
(source-atime (sb-posix:stat-atime source-stat))
(source-mtime (sb-posix:stat-mtime source-stat)))
(set-file-write-date (sb-ext:native-namestring target-pathname-or-namestring) source-atime source-mtime)))
(defun timestamp-for-file-with (&key (prefix (make-string 0))
(suffix (make-string 0))
(universal-time nil))
(declare (string prefix suffix)
(boolean universal-time)
(optimize (speed 3)))
(and (zerop (string-length prefix))
(zerop (string-length suffix))
(error ":FUNCTION `timestamp-for-file-with' -- keys PREFIX and SUFFIX ~
were not provided or both the empty string."))
(flet ((trim-key-strings (key-string)
(declare (string key-string))
(let ((rtn (string-trim `(#\_ #\- ,@*whitespace-chars*) key-string)))
(if (zerop (string-length rtn))
nil
rtn))))
(let ((maybe-pfx (trim-key-strings prefix))
(maybe-sfx (trim-key-strings suffix))
(tstamp (timestamp-for-file :universal-time universal-time)))
(declare (string-or-null maybe-sfx maybe-pfx tstamp))
(and (null maybe-pfx)
(null maybe-sfx)
(error ":FUNCTION `timestamp-for-file-with' -- keys PREFIX and SUFFIX were or became null~% ~
prefix: ~S became: ~S ~% suffix: ~S became: ~S~%" prefix maybe-pfx suffix maybe-sfx))
(and prefix
(null maybe-pfx)
(zerop (length maybe-sfx))
(error ":FUNCTION `timestamp-for-file-with' -- key PREFIX became null~% ~
prefix: ~S became: ~S ~%" prefix maybe-pfx))
(and suffix
(null maybe-sfx)
(zerop (length maybe-pfx))
(error ":FUNCTION `timestamp-for-file-with' -- key SUFFIX became null~% ~
suffix: ~S became: ~S ~%" suffix maybe-sfx))
(cond ((and maybe-pfx maybe-sfx)
(concatenate 'string maybe-pfx "-" tstamp "-" maybe-sfx))
(maybe-pfx
(concatenate 'string maybe-pfx "-" tstamp))
(maybe-sfx
(concatenate 'string tstamp "-" maybe-sfx ))))))
;;; ==============================
;; :COURTESY Nikodemus Siivola
;; :SEE (URL `git://github.com/nikodemus/fsdb.git')
;; :FILE fsdb/src/sbcl.lisp
;; :NOTE `ensure-directory-pathname' retuns a namestring _even if_ PATH names a file.
;; It is intended to be passed directly to `cl:ensure-directories-exist'
;; #+:sbcl
;; (defun ensure-directory-pathname (path)
;; (sb-ext:parse-native-namestring
;; (sb-ext:native-namestring (pathname path) :as-file nil) ;<THING>
;; nil ; <HOST>
;; *default-pathname-defaults* ; <DEFAULTS>
;; :as-directory t ;; :START 0 :END nil :JUNK-ALLOWED nil
;; ))
;;; ==============================
#+:sbcl
(defun directory-pathname-ensure (path)
(declare (pathname-or-namestring path))
(let* ((path-pathname (pathname path))
(name (if (wild-pathname-p path-pathname)
(file-error-wild-pathname :w-sym "directory-pathname-ensure"
:w-type 'function
:pathname path
:path-arg-locus "PATH"
:signal-or-only nil)
;; osicat-sys:native-namestring <-- cffi-sys:native-namestring <-- sb-ext:native-namestring <-- (funcall (host-unparse-native host) pathname as-file)
(sb-ext:native-namestring path-pathname :as-file nil)))
(kind (osicat:file-kind name :follow-symlinks t)))
(unless kind
(simple-error-mon :w-sym "directory-pathname-ensure"
:w-spec "Arg PATH not regular-file, directory, symlink, or special-file"
:w-got path
:w-type-of t
:signal-or-only nil))
(ecase kind
(:DIRECTORY
(sb-ext:parse-native-namestring name nil *default-pathname-defaults* :as-directory t))
((:FILE :REGUALR-FILE)
(values path-pathname (length name))))))
(defun pathname-or-namestring-empty-p (maybe-empty-pathname-or-namestring)
(declare (inline pathname-or-namestring-p string-empty-p)
(optimize (speed 3)))
(unless (pathname-or-namestring-p maybe-empty-pathname-or-namestring)
(return-from pathname-or-namestring-empty-p nil))
(locally
(declare (pathname-or-namestring maybe-empty-pathname-or-namestring))
(etypecase maybe-empty-pathname-or-namestring
(string (string-empty-p maybe-empty-pathname-or-namestring))
(pathname (pathname-empty-p maybe-empty-pathname-or-namestring)))))
;;; :SOURCE freedius/lisp/lisp/lisp-io.lisp
;;; :NOTE Following returns true (unix-dot-directory-p "/bubba/.")
(defun unix-dot-directory-p (path)
(unless (filename-designator-p path)
(return-from unix-dot-directory-p nil))
(locally (declare (filename-designator path))
(let* ((frob-path (if (pathnamep path)
(namestring path)
path))
(rt-side (subseq (the string frob-path)
(1+ (or
(position #\/ (the string frob-path) :from-end t :test #'char=)
-1)))))
(or (string= rt-side ".")
(string= rt-side "..")))))
;;; ==============================
;; :NOTE Should we include the type FILE-STREAM?
;; No, not right now.
;; Write a `pathname-designator-not-empty-relative-or-wild-p'
;; if/when that is what is wanted.
;;
;; (when (and (typep maybe-sane-pathname 'file-stream)
;; (open-stream-p maybe-sane-pathname))
;; (return-from pathname-or-namestring-not-empty-dotted-or-wild-p t))
;;
(defun pathname-or-namestring-not-empty-dotted-or-wild-p (maybe-sane-pathname &key (no-relatives nil))
(declare (boolean no-relatives)
(inline pathname-or-namestring-p)
(optimize (speed 3)))
(unless (pathname-or-namestring-p maybe-sane-pathname) ;; filename-designator-p
(return-from pathname-or-namestring-not-empty-dotted-or-wild-p nil))
(let ((non-path-string-things (list "" "." ".." " "))) ; the empty string is required for namestrings.
(declare (pathname-or-namestring maybe-sane-pathname)
(list non-path-string-things))
(when no-relatives
(setf non-path-string-things (nconc (list "../" "./") non-path-string-things)))
#-:sbcl (and
(not (pathname-or-namestring-empty-p maybe-sane-pathname))
(not (member maybe-sane-pathname non-path-string-things))
(not (wild-pathname-p (pathname maybe-sane-pathname)))
t)
(etypecase maybe-sane-pathname
(pathname
(setf non-path-string-things (map 'list #'pathname non-path-string-things))
(and (not (pathname-empty-p maybe-sane-pathname))
(not (member maybe-sane-pathname non-path-string-things :test #'sb-impl::pathname=))
(not (wild-pathname-p maybe-sane-pathname))
t))
(string
(and
(not (member maybe-sane-pathname non-path-string-things :test #'string=))
(not (wild-pathname-p (pathname maybe-sane-pathname)))
t)))))
;; :NOTE This is basically a rewrite of `%probe-file-if-string-or-pathname' below.
(defun pathname-not-wild-empty-or-dotted-p (maybe-valid-pathname)
(declare (inline pathname-or-namestring-p)
(optimize (speed 3)))
(unless (pathname-or-namestring-p maybe-valid-pathname)
(return-from pathname-not-wild-empty-or-dotted-p
(values nil (list (type-of (pathname maybe-valid-pathname)) maybe-valid-pathname))))
(locally (declare (pathname-or-namestring maybe-valid-pathname))
(when (wild-pathname-p maybe-valid-pathname)
(return-from pathname-not-wild-empty-or-dotted-p
(values nil (list :WILD (pathname maybe-valid-pathname)))))
(let ((dots (list ".." ".")))
(etypecase maybe-valid-pathname
(string
(if (string-not-empty-or-all-whitespace-p (the string maybe-valid-pathname))
(if (member (the string maybe-valid-pathname) dots :test 'string=)
(values nil (list :STRING-DOTTED maybe-valid-pathname))
(values t (list :STRING maybe-valid-pathname)))
(if (string-empty-p (the string maybe-valid-pathname))
(values nil (list :PATHNAME-EMPTY (make-pathname :defaults maybe-valid-pathname)))
(values nil (list :STRING-WHITESPACE maybe-valid-pathname)))))
(pathname
;; Don't allow the empty pathname to qualify as a pathname.
;; we can always recover it with:
;; (apply 'make-pathname (%probe-file-if-string-or-pathname #P""))
(cond ((equal maybe-valid-pathname (make-pathname :defaults ""))
(values nil (list :PATHNAME-EMPTY maybe-valid-pathname)))
((member maybe-valid-pathname (map 'list #'pathname (the list dots)) :test 'equal)
(values nil (list :PATHNAME-DOTTED maybe-valid-pathname)))
((every #'whitespace-char-p (the string (namestring maybe-valid-pathname)))
(values nil (list :PATHNAME-WHITESPACE maybe-valid-pathname)))
(t (values t (list :PATHNAME maybe-valid-pathname)))))))))
(declaim (inline %probe-file-if-string-or-pathname))
(defun %probe-file-if-string-or-pathname (putative-pathname) ;; &key (as-pathnames t)
;; Is putative-pathname `cl:stringp' or `cl:pathnamep' if so return its `cl:pathname'.
(unless ;; (or (stringp putative-pathname) (pathnamep putative-pathname))
;;(pathname-or-namestring-p maybe-valid-pathname))
(filename-designator-p putative-pathname)
(return-from %probe-file-if-string-or-pathname
(values nil (type-of putative-pathname))))
(locally
(declare (pathname-or-namestring putative-pathname))
;; (let ((nrmlz-to-pathname (pathname putative-pathname)))
;; (declare (pathname nrmlz-to-pathname))
(etypecase putative-pathname
(string (if (string-not-empty-or-all-whitespace-p putative-pathname)
(values (pathname putative-pathname) :STRING)
(values nil :STRING-EMPTY)))
(pathname
;; Don't allow the empty pathname to qualify as a pathname.
;; we can always recover it with:
;; (apply 'make-pathname (%probe-file-if-string-or-pathname #P""))
(if (equal putative-pathname (make-pathname))
(values nil :PATHNAME-EMPTY)
(values putative-pathname :PATHNAME))))))
(defun pathname-native-file-kind (putative-pathname &key (error-on-wild nil)) ;; &key (as-pathnames t)
(declare (inline %probe-file-if-string-or-pathname)
(boolean error-on-wild)
(optimize (speed 3)))
(let* ((pathname-chk
(multiple-value-bind (pnfk-chk pnfk-typ) (%probe-file-if-string-or-pathname putative-pathname)
(if pnfk-chk
(if (wild-pathname-p pnfk-chk)
(if error-on-wild
(file-error-wild-pathname :w-sym "pathname-native-file-kind"
:w-type 'function
:pathname putative-pathname
:path-arg-locus "PUTATIVE-PATHNAME"
:signal-or-only nil)
(return-from pathname-native-file-kind (values nil (list :WILD pnfk-chk))))
(cons pnfk-chk pnfk-typ))
;; If we've wound up here we return either:
;; (:STRING-EMTPY "") | (:PATHNAME-EMPTY #P"")
;; :NOTE There is no "kind" for an emtpy string or an emtpy path, e.g.:
;; (eq (sb-impl::native-file-kind "") (%probe-file-if-string-or-pathname ""))
;; (eq (sb-impl::native-file-kind "") (%probe-file-if-string-or-pathname #P""))
;; In either case, we can recover the pathname with:
;; (multiple-value-bind (kind path) (pathname-native-file-kind "")
;; (if (null kind ) (make-pathname) path))
;; (return-from pathname-native-file-kind (values pnfk-chk pnfk-typ))
(case pnfk-typ
((:PATHNAME-EMPTY :STRING-EMPTY)
(return-from pathname-native-file-kind (values pnfk-chk (list pnfk-typ putative-pathname))))
(t (return-from pathname-native-file-kind (values pnfk-chk pnfk-typ)))))))
(pathname-namestring-if
(osicat-sys:native-namestring (the pathname (car pathname-chk)))))
(declare (cons pathname-chk)
(string pathname-namestring-if))
(values
(osicat:file-kind pathname-namestring-if)
(ecase (cdr pathname-chk)
(:STRING pathname-namestring-if)
(:PATHNAME (pathname pathname-namestring-if))))))
;;; ==============================
;;; :NOTE In the followings ecause clauses, the first value is as per return
;;; value of `sb-impl::native-file-kind' -- Any remaining values are as per
;;; return value of return value of `osicat:file-kind'. Hopefully this arangment
;;; may allow us to switch which we rely on as needed...
(defun probe-directory (putative-pathname-dir)
(let* ((pathname-chk
(multiple-value-list (pathname-native-file-kind putative-pathname-dir)))
(pathtype-chk (car pathname-chk)))
(ecase pathtype-chk
;; :FIXME NIL is a corner case for :WILD, :PATHNAME-EMPTY, :STRING-EMPTY, etc.
;; specialize with case around caadr of pathname-chk.
;; Or, better yet m-v-b instead of let binding above and CL:CASE inspect
;; the m-v-b'd 1 value instead.
((nil) (values pathtype-chk (cadr pathname-chk) putative-pathname-dir))
((:REGULAR-FILE :FILE)
(values nil pathtype-chk (cadr pathname-chk)))
((:SOCKET :BLOCK-DEVICE :CHARACTER-DEVICE :SPECIAL)
(values nil pathtype-chk (cadr pathname-chk)))
((:SYMBOLIC-LINK :SYMLINK)
;; :TODO Now that we're using osicat:file-kind we can rexamine whether the
;; link is borken or not by re-examining the file and checking for
;; symbolic-link-broken.
(let ((probed (probe-file (cadr pathname-chk))))
(values nil pathtype-chk (cons (pathname (cadr pathname-chk)) probed))))
(:DIRECTORY
(values (truename (cadr pathname-chk))
pathtype-chk
(cons (cadr pathname-chk) putative-pathname-dir))))))
(defun pathname-file-if (putative-pathname &key allow-directory) ;; (as-pathnames t)
(declare (inline %probe-file-if-string-or-pathname)
(optimize (speed 3)))
(let* ((pathname-chk (multiple-value-bind (pfi-str-or-pth pfi-val)
(%probe-file-if-string-or-pathname putative-pathname)
(if pfi-str-or-pth
pfi-str-or-pth
(return-from pathname-file-if (values pfi-str-or-pth pfi-val)))))
(pathname-if pathname-chk))
(declare (pathname pathname-if))
;; :NOTE The non-SBCL version has a different behaviour w/r/t symlinks!
;; #-:sbcl
;; (when (setf pathname-chk (probe-file pathname-if))
;; (locally (declare (pathname pathname-chk))
;; (if allow-directory
;; pathname-chk
;; (when (not (equal pathname-chk
;; (make-pathname :directory (pathname-directory pathname-chk))))
;; pathname-chk))))
;; #+:sbcl
(multiple-value-bind (path-type path-if) (pathname-native-file-kind pathname-if)
(ecase path-type
;; NIL is a corner case for :WILD, :PATHNAME-EMPTY, :STRING-EMPTY, etc.
;; we keep it separate from :symlink :special for clarity
((nil) nil)
((:SYMBOLIC-LINK :SOCKET :BLOCK-DEVICE :CHARACTER-DEVICE ; osicat:file-kind
:SYMLINK :SPECIAL) ; sb-impl::native-file-kind
nil)
((:REGULAR-FILE :FILE)
(truename path-if))
(:DIRECTORY (when allow-directory
(truename path-if)))))))
(defun pathname-file-list-if (namestring-list &key allow-directory (as-pathnames t))
(declare (boolean as-pathnames))
(flet ((filter-files (filename)
(pathname-file-if filename :allow-directory allow-directory)))
(let ((filtered (remove-if-not #'filter-files namestring-list)))
(declare (list filtered))
(if as-pathnames
(loop for path in filtered collect (pathname path))
(loop for path in filtered collect (namestring path))))))
;; :SOURCE slime/swank.lisp :WAS `merged-directory'
(defun pathname-directory-merged (dirname pathname-defaults)
(pathname-directory (pathname-directory-append dirname pathname-defaults)))
;; :SOURCE slime/swank-loader.lisp :WAS `append-dir'
(defun pathname-directory-append (dirname pathname-defaults)
(merge-pathnames
(make-pathname :directory `(:relative ,dirname)
;; :directory (or absolute *default-pathname-defaults*))
:defaults pathname-defaults)
pathname-defaults))
;;; ==============================
;; (fundoc 'subfile
;; "Return a file pathname with name SUB in DIRECTORY-PATHNAME.
;; MAKE-PATHNAME-KEYWORDS are passed to MAKE-PATHNAME. When DIRECTORY-PATHNAME is
;; NIL, it is interpreted to be cl:*default-pathname-defaults*.
;; :EXAMPLE~%~@
;; { ... <EXAMPLE> ... } ~%~@
;; :SEE-ALSO `<XREF>'.~%▶▶▶")
;;
;; (defun subfile (directory-pathname sub &rest make-pathname-keywords)
;; (merge-pathnames (apply #'make-pathname
;; :directory `(:relative ,@(butlast sub))
;; :name (alexandria:lastcar sub)
;; make-pathname-keywords)
;; (or directory-pathname *default-pathname-defaults*)))
;;; ==============================
;;; ==============================
;; (defun append-slash (path)
;; "append / to path if there is none at the end"
;; (if (char= (car (last (coerce path 'list))) #\/)
;; (setf path (concatenate 'string path "/")))
;; path)
;;
;;; :COURTESY buildapp-1.1/utils.lisp :WAS `directorize'
(defun directorize-namestring (namestring)
(declare (filename-designator namestring))
(concatenate 'string (string-right-trim "/" (namestring namestring))))
;;; :COURTESY freedius/lisp/lisp/lisp-io.lisp
(defun rename-file* (file new-name)
(declare (filename-designator file new-name))
(flet ((wild-error (path locus)
(file-error-wild-pathname :w-sym "replace-file"
:w-type 'function
:pathname path
:path-arg-locus locus
:signal-or-only nil)))
(when (wild-pathname-p file)
(wild-error file "FILE"))
(when (wild-pathname-p new-name)
(wild-error new-name "new-name")))
(if (pathname-type new-name)
(rename-file file new-name)
(rename-file file (make-pathname :defaults new-name :type :UNSPECIFIC))))
;;; :SOURCE quicklisp/quicklisp/utils.lisp
(defun replace-file (from to)
(declare (type filename-designator from to))
(flet ((wild-error (path locus)
(file-error-wild-pathname :w-sym "replace-file"
:w-type 'function
:pathname path
:path-arg-locus locus
:signal-or-only nil)))
(when (wild-pathname-p from)
(wild-error from "FROM"))
(when (wild-pathname-p to)
(wild-error from "FROM")))
(when (probe-file to)
(delete-file to))
(rename-file from to))
;;; ==============================
;; :TODO This should be more careful about the empty string and `cl:wild-pathname-p'
;;
;; :TODO This should disallow linking directories (esp. when HARD is t)
;; The logic being, if we want to hardlink a directory we shoul do it that
;; _hard_ way to ensure a higher level of awareness w/r/t the potential negative
;; consequences!
;;
;; :TODO use osicat:make-link instead
(defun make-symlink (&key target link-name (hard nil))
(declare (boolean hard)
(pathname-or-namestring target link-name))
;;
;; (osicat:make-link :target target link-name :hard hard)
;;
#-(or (and sbcl (not win32)) ecl ccl) (error "`make-symlink' not-implemented") ;; (and clisp unix)
#+(and sbcl (not win32))
(if hard
(sb-posix:link target link-name)
(sb-posix:symlink target link-name))
;;
;; I don't find this on Clisp 2.49
;; #+(and clisp unix) (linux:symlink link-name add-symlink-at)
;;
;; :NOTE We assume the GNU longopts are in play when ECL is.
#+ecl (ext:run-program "/bin/ln" (if hard
(list (namestring target) (namestring link-name))
(list "--symbolic" (namestring target) (namestring link-name)))
:wait t :input nil :output nil :error nil)
;;
;; According to oGMo on #lisp as of 10.5.8 GNU longopts are not accepted.
#+ccl (ccl:run-program "/bin/ln"
(if hard
(list (namestring target) (namestring link-name))
(list "-s" (namestring target) (namestring link-name)))
:wait t :input nil :output nil :error nil))
;;; :SOURCE quicklisp/quicklisp/utils.lisp
;;
;; :NOTE Definition of `cl:open' in :FILE sbcl/src/code/fd-stream.lisp
;; has this:
;; ,----
;; | (:probe (values t nil sb!unix:o_rdonly))
;; `----
;; where sb!unix:o_rdonly is a constant => #x0 e.g. a null byte.
;;
;; The :direction :probe causes cl:open to effectively evalutate to:
;; ,----
;; | (let ((stream (%make-fd-stream :name namestring
;; | :fd fd
;; | :pathname pathname
;; | :element-type element-type)))
;; | (close stream)
;; | stream)
;; `----
;;
;; :NOTE Also that :external-format is not likely needed b/c were just pinging a
;; file descriptor.
;;
;; Also, the `fd-stream' defstruct in :FILE sbcl/src/code/fd-stream.lisp
;; hash this:
;; ,----
;; | ;; Not :DEFAULT, because we want to match CHAR-SIZE!
;; | (external-format :latin-1)
;; `----
;;
;; :external-format SB-IMPL::*DEFAULT-EXTERNAL-FORMAT*
;; :element-type
;;
(defun ensure-file-exists (pathname)
(declare (type pathname-designator pathname))
(open pathname
:direction :probe
:if-does-not-exist :create))
;: :TODO This should be more careful about deleting directories when
;; pathname-to-delete is a symlink in file form.
(defun delete-file-if-exists (pathname-to-delete)
(declare (type pathname-designator pathname-to-delete))
(when (or (streamp pathname-to-delete)
(wild-pathname-p pathname-to-delete))
;; `cl:delete-file' won't delete a directory and signals an error.
;; we should catch it before it has a chance.
;; (cl-fad:directory-pathname-p #P"./bubba/") *default-pathname-defaults*)
(let ((wrn (format nil
"~%~T:FUNCTION `delete-file-if-exists' --~%~12T~
declining to delete PATHNAME, got: ~S"
pathname-to-delete
;; (or (and (streamp pathname)
;; (string 'cl:streamp)
;; (string 'cl:wild-pathname-p))
;; *default-pathname-defaults*)
)))
(warn wrn)
(return-from delete-file-if-exists (values nil wrn))))
(when (probe-file pathname-to-delete)
(delete-file pathname-to-delete)))
;; :SOURCE buildapp-1.1/utils.lisp
;; :NOTE differs from `cl-fad:copy-file' element-type is always 'character
;; :NOTE what about an :external-format?
(defun copy-file (input output &key (if-output-exists :supersede) ;; overwrite
(external-format :default))
(with-open-file (input-stream input
:direction :input
:if-does-not-exist :error
:element-type 'character
:external-format external-format)
(with-open-file (output-stream output
:direction :output
:if-exists if-output-exists
:element-type 'character
:external-format external-format)
(loop
for char = (read-char input-stream nil)
while char
do (write-char char output-stream)))))
;; :SOURCE mcclim/Apps/Listener/util.lisp :WAS `strip-filespec'
(defun pathname-strip-filespec (pathname)
;; (declare (type pathname-designator pathname)) ;; don't bother with a file-stream!
(declare (filename-designator pathname))
(make-pathname :name nil
:type nil
:version nil
#+scl :query #+scl nil
:defaults (pathname pathname)))
(defun directory-parent (of-pathname)
(declare (filename-designator of-pathname))
(let ((of-path (pathname of-pathname)))
(declare (pathname of-path))
(make-pathname :host (pathname-host of-path)
:device (pathname-device of-path)
;; :NOTE consider using `osicat::component-present-p'
:directory (if (and (pathname-name of-path)
(not (eq :unspecific (pathname-name of-path))))
(pathname-directory of-path)
(butlast (pathname-directory of-path))))))
;; :SOURCE cl-docutils-20101006-git/utilities.lisp :WAS `find-file'
(defun find-file-search-path (search-file &key (search-path (or *search-path* (list *default-pathname-defaults*))))
(declare (filename-designator search-file))
(let ((chk-search-file (if (pathname-not-wild-empty-or-dotted-p search-file)
(pathname search-file)
(file-error-wild-pathname :w-sym "find-file-search-path"
:w-type 'function
:pathname search-file
:path-arg-locus "search-file"
:signal-or-only nil)))
;; :NOTE (and (not (wild-pathname-p (sb-ext:posix-getenv "PATH"))) "$PATH is ok man")
;; However, this one is likely to cause loads of _FUN_ later:
;; (pathname-directory (sb-ext:posix-getenv "PATH"))
(chk-search-path
(if (pathname-not-wild-empty-or-dotted-p search-path)
;;
;; We get a namestring to allow for wackiness like this:
;; (pathname (sb-ext:posix-getenv "PATH"))
;; In which case we the pathname needs to be split into components.
;;
(osicat-sys:native-namestring search-path)
(file-error-wild-pathname :w-sym "find-file-search-path"
:w-type 'function
:pathname search-path
:path-arg-locus "search-path"
:signal-or-only nil))))
(flet ((find-fl (ffsp-dir)
(some #'probe-file
#-:sbcl (directory (merge-pathnames chk-search-file ffsp-dir))
#+:sbcl (directory (merge-pathnames chk-search-file ffsp-dir) :resolve-symlinks nil))))
;; (declare (pathname-or-namestring chk-search-path))
(some #'(lambda (w-path)
(etypecase w-path
(list (some #'find-fl w-path))
(string (some #'find-fl (string-split-on-chars w-path ":")))
(pathname (find-fl w-path))))
chk-search-path))))
;; :NOTE As of 2011-08-11 when directory is "." or ".." return value
;; of cl-fad:list-directory and osicat:list-directory differ there is a
;; bug in osicat:call-with-directory-iterator that weirdly binds
;; *d-p-d* via osicat:absolute-pathname e.g.
;; (osicat:absolute-pathname ".")
;; returns the equivalent of:
;; (merge-pathnames "." *default-pathname-defaults*)
;; We manage to avoid this with osicat:file-exists-p but it is worth keeping in mind!
(defun directory-files (directory &key (bare-pathnames nil)) ;; &optional full match nosort)
(declare (filename-designator directory)
(boolean bare-pathnames))
(let ((dir-pathname
(if (wild-pathname-p directory)
(file-error-wild-pathname :w-sym "replace-file"
:w-type 'function
:pathname directory
:path-arg-locus "directory"
:signal-or-only nil)
(pathname directory))))
(declare (pathname dir-pathname))
(and (setf dir-pathname
;; (or (cl-fad:directory-exists-p (mon::pathname-as-directory dir-pathname)) ;; :error-on-empty t))
(or (nth-value 0 (osicat:file-exists-p (mon::pathname-as-directory dir-pathname) :directory))
;; :NOTE The idea behind returning values was to allow further
;; processing for the (non-existent) FULL MATCH args and or to allow restarts.
;; If we aren't going to provide restarts around this it would
;; prob. be better to just signal an error.
(return-from directory-files
(values dir-pathname (osicat:file-exists-p dir-pathname :directory)))))
(osicat:list-directory dir-pathname :bare-pathnames bare-pathnames))))
(defun directory-unfiltered-p (directory-name &key (ignorables *default-pathname-directory-ignorables* supplied-p)
(test 'string=))
(declare (pathname-or-namestring directory-name)
((and cons list) ignorables)
(optimize (speed 3)))
;; Lets just assume that the default value of
;; *default-pathname-directory-ignorables* is sanely bound...
;;
;; Would it be better to make ignorables as class instance and run the
;; following in an after method on it?
(when supplied-p
(unless (every #'stringp ignorables)
(simple-error-mon :w-sym "directory-unfiltered-p"
:w-type 'function
:w-spec "Element of IGNORABLES not `cl:stringp'~%IGORABLES: ~S"
:w-args (list ignorables)
:w-got (find-if-not #'stringp ignorables)
:w-type-of t)))
(labels ((member-frob (chk-member)
(declare (string chk-member))
(not (member chk-member ignorables :test test)))
(psn-slash (maybe-slash)
(declare (string maybe-slash))
(position #\/ maybe-slash))
(token-component-p (maybe-component-only)
(when (and (stringp maybe-component-only)
(not (wild-pathname-p (the string maybe-component-only))))
(when (or (string-empty-p (the string maybe-component-only))
(member (the string maybe-component-only) (list ".." ".") :test 'string=))
(multiple-value-bind (pnfk-0 pnfk-1) (pathname-native-file-kind maybe-component-only)
(ecase pnfk-0
((nil) (return-from directory-unfiltered-p (values pnfk-0 pnfk-1)))
(:DIRECTORY (return-from directory-unfiltered-p (values nil (list pnfk-0 pnfk-1)))))))
(not (psn-slash (the string maybe-component-only)))))
(full-frob (frob-component)
(when (token-component-p frob-component)
;; We bail now, but we pack the list so that even if
;; `member-frob' returns T the return values of
;; `directory-unfiltered-p' will not be easily coercible to a
;; real pathname e.g. callers will get either:
;; T, (:STRING <DIRECTORY-NAME>)
;; NIL, (:STRING <DIRECTORY-NAME>)
(return-from full-frob (list frob-component (list :STRING frob-component))))
(multiple-value-bind (key-or-null path-string-or-type) (pathname-native-file-kind directory-name)
(case key-or-null
((:FILE :REGULAR-FILE)
(return-from directory-unfiltered-p
(values t (list key-or-null (pathname path-string-or-type)))))
(:DIRECTORY
;; :FIXME This is not quite right yet b/c we don't want to traverse symlinks...
;; If a dir is passed as a native filename then `pathname-native-file-kind' should identify it as a symlink.
;; To accommodate not following we need to requery with
;; (directory <DIR> :resolve-symlinks nil) and compare the
;; output if they are equal we have a real dir, else we have a
;; symlink to an existing directory and we should put
;; path-string-or-type in pathname form and return now with either:
;; (NIL (:SYMLINK #P"/pathnae/of/symlink"))
;; (NIL (:SYMLINK #P"/pathnae/of/symlink/"))
;;
(let* ((dir-path (car (directory path-string-or-type)))
(dir-compt (last-elt (pathname-directory dir-path))))
(list dir-compt (list :DIRECTORY dir-path))))
((nil)
(cond
((listp path-string-or-type)
(case (car path-string-or-type)
;; "" -> NIL, (:STRING-EMPTY "")
;; #P"" -> NIL, (:PATHNAME-EMPTY #P"")
((:STRING-EMPTY :PATHNAME-EMPTY)
(return-from directory-unfiltered-p (values key-or-null path-string-or-type)))
;; "weird-and-wild/*" -> NIL, (:WILD #P"weird-and-wild/*")
(:WILD (return-from directory-unfiltered-p (values key-or-null path-string-or-type)))))
;; "bogus-string-component/" -> NIL, (:STRING "bogus-string-component/")
((and (stringp path-string-or-type) (psn-slash path-string-or-type))
(return-from directory-unfiltered-p (values key-or-null (list :STRING path-string-or-type))))
;; #P"bogus-and-weird-path/" -> NIL, (:RELATIVE "bogus-and-weird-path")
((pathnamep path-string-or-type)
(return-from directory-unfiltered-p (values key-or-null (pathname-directory path-string-or-type))))
;; ??weird an unknown?? -> NIL, (NIL ??weird an unknown??)
(t (return-from directory-unfiltered-p
(values key-or-null (list NIL path-string-or-type))))))
;; "/some/special" | #P"/some/special" -> (NIL (:SPECIAL #P"/some/special"))
((:SYMLINK :SPECIAL ; sb-impl::native-file-kind
:SYMBOLIC-LINK :SOCKET :BLOCK-DEVICE :CHARACTER-DEVICE) ; osicat:file-kind
(return-from directory-unfiltered-p
(values nil (list key-or-null (pathname path-string-or-type)))))
;; it may be a string component
(t (if (stringp path-string-or-type)
(if (not (token-component-p path-string-or-type))
(return-from directory-unfiltered-p (values nil (list :STRING path-string-or-type)))
(list path-string-or-type (list :STRING path-string-or-type)))
;; who fu**ing knows what it is...
;; (return-from directory-unfiltered-p (values nil (list :WTF key-or-null path-string-or-type)))
(return-from directory-unfiltered-p (values nil (list key-or-null path-string-or-type )))))))))
;; (full-frob directory-name)))
(let* ((dir-part-if (full-frob directory-name))
(chk-if (if (stringp (car dir-part-if))
(car dir-part-if)
(return-from directory-unfiltered-p (values nil (cdr dir-part-if))))))
(declare (string chk-if))
(values (member-frob chk-if) (cadr dir-part-if)))))
;; WORKS!
;; (ignorables *default-pathname-directory-ignorables* supplied-p) (test 'string=))
;; (print
(defun tt--gather-dir-list (dir) ;; (test 'string=) (ignorables *default-pathname-directory-ignorables* supplied-p)
;; gather list of files and directories in dir filtering them with `mon:directory-unfiltered-p'.
;; directories are included in the result we do not descend into any directory that satsifies #'directory-unfiltered-p
;;
;; (tt--gather-dir-list *default-pathname-defaults*)
(let ((gthr-dir-and-files '()))
(flet ((partition-file-or-dir (dir-file-or-other)
(multiple-value-bind (n0-t-or-nil n1-dir-file-or-other-type) (directory-unfiltered-p dir-file-or-other)
(case n1-dir-file-or-other-type
((:DIRECTORY :FILE :REGULAR-FILE)
(push n1-dir-file-or-other-type gthr-dir-and-files)
n0-t-or-nil)
(t (print n1-dir-file-or-other-type) n0-t-or-nil)))))
;; (osicat:walk-directory
(cl-fad:walk-directory dir
#'constantly ; all work done with test fncn PARTITION-FILE-OR-DIR
:test #'partition-file-or-dir
:directories :breadth-first
;; :if-does-not-exist
)
gthr-dir-and-files)))
;;; ==============================
;; :PASTED (URL `http://paste.lisp.org/+2N64')
;; :NOTE I don't find CL-FAD:PATHNAME-AS-FILE particularly sane w/r/t the empty string.
;; It isn't portable and it doesn't fail in obvious ways.
;; following is an attempt at fixing that.
;; :NOTE osicat:pathname-as-file is nearly 1:1 identical with
;; cl-fad:pathname-as-file for Osicat distributed with Quicklisp
;; osicat-20110619-git/src/osicat.lisp and also accepts the empty string.
(defun pathname-as-file (pathspec &key (error-on-empty nil))
(declare (pathname-or-namestring pathspec)
(optimize (speed 3)))
(let ((paf-name (pathname pathspec)))
(declare (pathname paf-name))
(when (wild-pathname-p paf-name)
(file-error-wild-pathname :w-sym "pathname-as-file"
:w-type 'function
:pathname pathspec
:path-arg-locus "PATHSPEC"
:signal-or-only nil))
(when (zerop (length (the simple-string (namestring paf-name))))
(if error-on-empty
(error "cl:namestring of PATHSPEC evaluates to the emtpy string")
(return-from pathname-as-file (make-pathname :defaults pathspec))))
;;;;;;
;; (cond ((cl-fad:directory-pathname-p pathspec)
;; (let* ((directory (pathname-directory pathname))
;; (name-and-type (pathname (first (last directory)))))
;; (make-pathname :directory (butlast directory)
;; :name (pathname-name name-and-type)
;; :type (pathname-type name-and-type)
;; :defaults pathname)))
;; (t pathname))
;;;;;
(osicat:pathname-as-file paf-name)))
;; Like cl-fad:pathname-as-directory but more careful about the empty string.
;; :NOTE osicat:pathname-as-directory is nearly 1:1 identical with
;; cl-fad:pathname-as-directory for Osicat distributed with Quicklisp
;; osicat-20110619-git/src/osicat.lisp and also accepts the empty string.
(defun pathname-as-directory (pathspec &key (error-on-empty nil))
(declare (pathname-or-namestring pathspec)
(optimize (speed 3)))
(let ((pdp-name (pathname pathspec)))
(declare (pathname pdp-name))
(when (wild-pathname-p pdp-name)
(file-error-wild-pathname :w-sym "pathname-as-directory"
:w-type 'function
:pathname pathspec
:path-arg-locus "PATHSPEC"
:signal-or-only nil))
(when (zerop (length (the simple-string (namestring pdp-name))))
(if error-on-empty
(error "cl:namestring of PATHSPEC evaluates to the emtpy string")
(return-from pathname-as-directory (make-pathname :name nil :type nil :defaults pathspec))))
(osicat:pathname-as-directory pdp-name)))
;;
;; :FIXME Verify this is correct.
(defun pathname-directory-pathname (pathspec) ;; &key (error-on-empty nil))
(let ((ensure-pathname (pathname pathspec)))
(make-pathname :name nil :type nil :defaults ensure-pathname)))
(defun make-pathname-user-homedir (&key user path)
(declare (string-or-null user)
(proper-list path))
#-:sbcl (check-type user string-or-null)
#-:sbcl (check-type path proper-list)
(if user
(if (string-not-empty-or-all-whitespace-p user)
(pathname (osicat-sys:native-namestring (make-pathname :directory `(:absolute :home ,user ,@path))))
(simple-error-mon :w-sym "make-pathname-user-homedir"
:w-type 'function
:w-spec "Keyword USER did not satisfy `mon:string-not-empty-or-all-whitespace-p'"
:w-got user
:w-type-of t
:signal-or-only nil))
(pathname
(osicat-sys:native-namestring
(make-pathname :directory `(,@(pathname-directory (user-homedir-pathname)) ,@path))))))
;; :NOTE This is a slightly tweaked cl-fad:directory-wildcard b/c there is no
;; osicat:directory-wildcard. Returns WILDEN-PATHNAME with pathname-name and pathname-type :wild
(defun make-pathname-directory-wildcard (wilden-pathname)
(declare (filename-designator wilden-pathname))
(when (wild-pathname-p wilden-pathname)
(file-error-wild-pathname :w-sym "make-pathname-directory-wildcard"
:w-type 'function
:pathname wilden-pathname
:path-arg-locus "WILDEN-PATHNAME"
:signal-or-only nil))
(make-pathname :name #-:cormanlisp :wild #+:cormanlisp "*"
:type #-(or :clisp :cormanlisp) :wild
#+:clisp nil
#+:cormanlisp "*"
:defaults (pathname-as-directory wilden-pathname)))
(defun make-pathname-directory-w-type-wild (base-pathname pathname-name)
(declare (filename-designator base-pathname)
(string-or-null pathname-name))
(unless (and (or (string-null-or-empty-p base-pathname)
(string-null-or-empty-p pathname-name)
(not
(setf base-pathname
(and (setf base-pathname (mon::pathname-as-directory base-pathname))
;; :WAS (or (cl-fad:directory-exists-p base-pathname)
(or (osicat:file-exists-p base-pathname :directory)
(return-from make-pathname-directory-w-type-wild
(values base-pathname (wild-pathname-p base-pathname))))))))
(values base-pathname (wild-pathname-p base-pathname)))
(setf base-pathname
(merge-pathnames
(make-pathname :name pathname-name :type :wild )
base-pathname))
(values base-pathname (wild-pathname-p base-pathname))))
;;; ==============================
;; :FINISH-ME
;; (defun make-pathname-directory-w-name-wild (pathname)
;; Return pathname with and pathname-type :wild
;; (declare (type filename-designator pathname))
;; (fad::directory-wildcard pathname))
;; :SOURCE asdf.lisp :WAS *wild-path*
;; (defparameter *wild-pathname*
;; (make-pathname :directory '(:relative :wild-inferiors)
;; :name :wild :type :wild :version :wild))
;; :SOURCE asdf.lisp :WAS `wilden'
;; merge-pathnames-with-wild
;; (defun* wilden (path)
;; (merge-pathnames* *wild-path* path))
;;
;; (defun probe-sbcl-source-file (subd file)
;; ;;(probe-file
;; (merge-pathnames
;; (make-pathname :directory `(:relative ,subd)
;; :name file
;; :type "lisp")
;; (make-pathname ; :name :wild :type "lisp" ;; wild
;; :directory `(,@(pathname-directory
;; (truename (sb-posix:getenv "DEVHOME")))
;; "CL-SYSTEMS" "sbcl" "src"))))
;;; ==============================
;;; ==============================
;;; :SOURCE freedius/freedius/lisp/system-tool/ev-pathnames.lisp
;;; This is a verision of `substitute-in-file-name' based on that found in emacs/src/fileio.c
;;; Originally, this required use of `*ev-getenv-auto-import*' and `ev-getenv'.
;;; Trying instead to use `sb-posix:getenv'/`sb-ext:posix-getenv'.
;;; The original source is included below should that not work.
;;; :NOTE :SEE `sb-ext:posix-environ' for additional ideas w/re `ev-getenv'.
;;;
;; (defparameter *ev-getenv-auto-import* :remember)
;;
;; (defun ev-getenv (var-name) ;; :was &optional (auto-import *ev-getenv-auto-import*))
;; (let ((symbol (intern var-name :env)))