#!/bin/sh
: ; exec klone $0 "$@"
; The above line finds the klone executable in the $PATH
;;Skeleton of a typical klone script
;;(stack-dump-on-error t)
;;(kdb t)

(setq args (getopts "USAGE: follow-link files...
print all links pointed to by files if they are symbolic links
traces and expands all links recursively
-> means symbolic link to
=  means expands to
== indicates final expansed file/dir
|<- 
|-> indicates a replacement of a left part of a path that was a link
"
    ("-q" () quiet "only list final destination")
    ("-l" () links-only "only lists links, ignore non-link arguments")
    ("-debug" () debug "very verbose operation, for debugging")
))

;; This script tries to edplore the path leading to the given files/directories
;; and resolve all the symbolic links.
;; It is quite complex due to the unix filesystem differences between relative
;; and absolute paths
;; e.g.: follow-link /usr/lib/gnu/cvs

(defun main (&aux
  )
  (dolist (file args)
    (if (or (not links-only) (file-is-symlink? file))
      (with (res
	  (show-link (strip-last-/ file) *current-directory*)
	)
	(if quiet
	  (print-format "%0\n" res)
)))))

;; print result, nothing printed if quiet

(defun PR (&rest args) 
  (if (not quiet) (progn (apply print-format args) (flush ()))))

;; follow links from file (must be absolute path)

(defun show-link (file dir &aux
    stats
    (printed-file file)
  )
  (PR "%0\n    " file)			;print name, indents for results
  (catch :return
    (setq file (expanse-relative file dir))
    (if (/= file printed-file)
      (throw :return (PR "=  ") (show-link file dir))
    )
    (setq printed-file file)
    (setq file (expand-intermediate-links file dir)) ;examine path
    (if (/= file printed-file)
      (throw :return (PR "=  ") (show-link file dir))
    )
    (if				;else, go on...
      (not (setq stats (file-stats file t))) (progn
	(PR "= %0\n      *** doesnt exists! ***\n" file)
	(+ "***NOT FOUND!*** " file)
      )
      
      (file-is-symlink? stats)		;symlink? recurse on the pointed path
      (progn
	(PR "-> ")
	(show-link (link-contents file) (dir-of file))
      )
      t					;plain file, stop and prints its ls -ldg
      (progn (PR "== %0\n       %1\n"
	  file
	  (match "^(.*) .*$" (String (sh:open ls -ldg ,file)) 1)
	)
	file
      )
)))

;; return the name of the file/dir a symlink points to
;; may be a relative name.

(defun link-contents (file &aux
    (res-fd (sh:open ls -ldg ,file))
    (result (String res-fd))
    (link (match "-> *(.*)$" result 1))
  )
  (PVD "***link-contents" file result link)
  (if link
    (while (= #\newline (get link (- (length link) 1)))
      (setq link (subseq link 0 (- (length link) 1)))
  ))
  (if link link "*** ERROR DEREFERENCING LINK ***")
)

;;strip pending / on dirs, often left by shell completions

(defun strip-last-/ (file &aux 
    (res (match "^(.*)[/]$" file 1))
  )
  (if res res file)
)

;;return the path part of file or pwd if file is a relative path

(defun dir-of (file &aux 
    (res (match "^(.*)[/][^/]+$" file 1))
  )
  (if res res *current-directory*)
)

;;file is symbolic link?
;;argument can be a filename (string) or stats (plist)

(defun file-is-symlink? (file)
  (if (typep file String) (setq file (file-stats file t)))
  (= S_IFLNK (logand S_IFMT (get file 'mode 0)))
)

;;expands links in the path to file, recursively

(setq expand-intermediate-links:re (regcomp "^([/]?[^/]+)[/]"))
(defun expand-intermediate-links (file dir &aux
    (offset 0)
    (path (copy ""))
  )
  (while (regexec expand-intermediate-links:re file offset)
    (setq path (+ path (regsub expand-intermediate-links:re 1)))
    (setq offset #[expand-intermediate-links:re 1 1])
    (PVD path)
    (if (file-is-symlink? path)
      (with (link (link-contents path))
	(PVD "before" path link)
	(PR "   |<- %0\n       |-> %1\n    " path link) 
	;; redo check on link
	(setq link (expanse-pathname link path))
	(setq link (expand-intermediate-links link dir))
	(setq path link)
	(PVD "after" path)
    ))
  )
  (+ path (if (and (/= "" path) (/= #\/ (get file offset))) "/" "")
    (subseq file offset))
)

(setq re-parent (regcomp "^[.][.][/](.*)$")) ; ../
(setq re-updir (regcomp "^(.*)[/][^/]*$")) ;remove last part
(setq re-updir2 (regcomp "^(.*)[/][^/]*[/][^/]*$")) ;remove the 2 last parts

;; takes path and replace its last component by file
;; trickyness due to relative paths and ../ files

(defun expanse-pathname (file dir &aux
  )
  (if 
    (regexec {regcomp "^[/]"} file)	;absolute dir
    file

    (regexec re-parent file)		; ../  -> updir
    (if (regexec re-updir2 dir)  ;can remove last 2parts?
      (expanse-relative  (regsub re-parent 1) (regsub re-updir2 1))
      ;; else, well, let it as is...
      (+ (match "^(.*[/])[^/]*$" dir 1) file)
    )
    					; rest: replace last part with file
    (+ (match "^(.*[/])[^/]*$" dir 1) file)
  )
)

;; exanses relative pathnames 

(defun expanse-relative (file dir)
  (if (regexec {regcomp "^[/]"} file)
    file				;absolute
    (progn ;relative
      (while (regexec re-parent file)
	(if (regexec re-updir dir) ;can remove last part?
	  (setqn file (regsub re-parent 1)
	    dir (regsub re-updir 1)
      )))				;otherwise, well, shit happens :-)
      (+ dir "/" file)
)))

(if debug (progn
    (kdb t)
    (trace show-link)
    (trace link-contents)
    (trace strip-last-/)
    (trace dir-of)
    (trace file-is-symlink?)
    (trace expand-intermediate-links)
    (trace expanse-pathname)
    (trace expanse-relative)
))

(main)

;;; EMACS MODES
;;; Local Variables: ***
;;; mode:lisp ***
;;; End: ***

