["Matt Swift" <address@hidden>] new-style Cygwin symlinks, NTEmacs' dired mode, and ls-lisp.el

[Jari Aalto]

    Sebastian and Emacs dev team, could you look at this code and
    incorporate it into the Main distributions. The code is
    welcomed in Win32 environment.

    Jari



-------------------- Start of forwarded message --------------------
X-From-Line: address@hidden  Thu Jul  4 01:39:40 2002
Received: from snickers.hotpop.com (snickers.hotpop.com [204.57.55.49])
 by faraday.tpu.fi (8.9.3/8.9.3) with ESMTP id BAA06106
 for <address@hidden>; Thu, 4 Jul 2002 01:39:39 +0300 (EET DST)
Received: from hotpop.com (kubrick.hotpop.com [204.57.55.16])
 by snickers.hotpop.com (Postfix) with SMTP id 722BA76A3C
 for <address@hidden>; Wed,  3 Jul 2002 22:39:30 +0000 (UTC)
Received: from sources.redhat.com (sources.redhat.com [209.249.29.67])
 by mx1.hotpop.com (Postfix) with SMTP id ACE34E8025
 for <address@hidden>; Wed,  3 Jul 2002 22:39:25 +0000 (UTC)
Received: (qmail 11353 invoked by alias); 3 Jul 2002 22:38:31 -0000
Mailing-List: contact address@hidden; run by ezmlm
Precedence: bulk
List-Unsubscribe: <mailto:address@hidden>
List-Subscribe: <mailto:address@hidden>
List-Archive: <http://sources.redhat.com/ml/cygwin/>
List-Post: <mailto:address@hidden>
List-Help: <mailto:address@hidden>, <http://sources.redhat.com/ml/#faqs>
Sender: address@hidden
Mail-Followup-To: address@hidden
Delivered-To: mailing list address@hidden
Received: (qmail 11290 invoked from network); 3 Jul 2002 22:38:28 -0000
Received: from unknown (HELO smtprelay9.dc2.adelphia.net) (64.8.50.53)
  by sources.redhat.com with SMTP; 3 Jul 2002 22:38:28 -0000
Received: from zayin ([24.48.255.101]) by
          smtprelay9.dc2.adelphia.net (Netscape Messaging Server 4.15)
          with ESMTP id GYP2W100.3CW; Wed, 3 Jul 2002 18:38:25 -0400 
From: "Matt Swift" <address@hidden>
To: <address@hidden>
Cc: <address@hidden>, <address@hidden>
Subject: new-style Cygwin symlinks, NTEmacs' dired mode, and ls-lisp.el
Date: Wed, 3 Jul 2002 18:38:17 -0400
Message-ID: <address@hidden>
X-Priority: 3 (Normal)
X-MSMail-Priority: Normal
Importance: Normal
X-MimeOLE: Produced By Microsoft MimeOLE V6.00.2600.0000
Lines: 159
Xref: W2KPICASSO list.cygwin:37159

Maybe this has already been done, but I have hacked ls-lisp.el so that
it understands the new-style Cygwin symlinks (which seem like Windows
shortcuts to Windows, but not to ls-lisp.el).  I have had to
reverse-engineer and hack without a full understanding of shortcut
headers.  Putting the following code in a startup .el file works for me
with EmacsNT 20.7.  It causes Emacs to do two things after loading
dired: load ls-lisp, then redefine one function defined in ls-lisp.el.
My modifications are commented and labeled with "MSS".   I am sending
this email because I think others may be interested in this code.
Someone with full knowledge could make this code more efficient and
address the question of robustness with odd file names and unusual
symlink headers.  

(defun swift-after-dired ()
  "Load `ls-lisp' library.
Redefine `ls-lisp-parse-w32-lnk'."

(load-library "ls-lisp")

; a Windows link and a Cygwin link to test:
; (ls-lisp-parse-w32-lnk "~/lib.lnk")
; (ls-lisp-parse-w32-lnk "~/library.lnk")
(defun ls-lisp-parse-w32-lnk (file)
  "Return file or directory referenced by MS Windows shortcut (.lnk)
FILE.
Return nil if the file cannot be parsed.
MSS modified."
  ;;  Based on \"The Windows Shortcut File Format\" as
  ;;  reverse-engineered by Jesse Hager <address@hidden>
  ;;  available from http://www.wotsit.org/download.asp?f=shortcut.
  (with-temp-buffer
    (set-buffer-multibyte nil)          ; need to force unibyte mode
here!
    (insert-file-contents file)
    (and
     ;; Parse the File Header Table.
     (looking-at "L\0\0\0")             ; otherwise not a shortcut file
     ;; Get the main flags dword at offset 14h.
     (let ((flags (ls-lisp-buffer-substring-as-int (+ (point) ?\x14) 4))
           ;; begin MSS mods
           ;; add a var to the `let'
           result)
       ;; Check for new-style cygwin symlinks.
       ;;
       ;; Beware: we seem to be in an environment where errors are
silently
       ;; passed over (how?! `with-temp-file'?), so debugging is a
challenge,
       ;; and the case of flags=12 and yet not the link we expect is a
       ;; problem.
       (if (and (equal flags 12)        ; number reverse engineered
                ;; always true, so will not affect `and'
;;;             (message "MSS | %s: flags 12" file)
                (setq result
                      ;; The following ought to return nil if we do not
have
                      ;; the link we expect.  I do not know what happens
if we
                      ;; pass the tests so far (.lnk suffix, flags=12)
and it
                      ;; is not a link.

                      ;; Returns the linked tofile name if `file' is a
                      ;; new-style Cygwin symlink.
                      (save-excursion
                                    (forward-char 78) ; number reverse
engineered
                                    (buffer-substring 79
                                                      (progn
        
(skip-chars-forward
                                                         ;; should
include at least all legal
                                                         ;; filename
chars; if it contains
                                                         ;; illegal
ones, that's OK as long as
                                                         ;; they won't
occur in the header
        
"a-zA-Z0-9\-\^\",./<>?;:'[]{}|address@hidden&*()-=_+")
                                                        (point))))))
           (progn
;;;          (message "MSS | Result: [%s]" result)
             result)

         ;; ELSE not a new-style Cygwin symlink but maybe a Windows
shortcut.

;;;      (message "MSS | %s: flags other" file)
         ;; end MSS mods, except one more paren below, because the
following are
         ;; the `else' forms now (also the `message' just above).

         ;; Bit 1 set means shortcut to file or directory:
         (when (= (logand flags 2) 2)
           ;; Skip to end of Header:
           (forward-char ?\x4C)
           ;; Skip Shell Item Id List.
           ;; It is present if flags bit 0 is set, in which case the
list
           ;; length is the first word, which must also be skipped:
           (if (= (logand flags 1) 1)
               (forward-char
                (+ 2 (ls-lisp-buffer-substring-as-int (point) 2))))
           ;; Parse the File Location Info Table.
           ;; The full file pathname is (generally) stored in two
           ;; pieces: a head depending on whether the file is on a local
           ;; or network volume and a remaining pathname tail.
           ;; Get and check the volume flags dword at offset 8h:
           (setq flags (ls-lisp-buffer-substring-as-int (+ (point) ?\x8)
4))
           (if (/= (logand flags 3) 0)  ; Must have bit 0 or 1 set.
               (let ((head              ; Get local or network
                      (save-excursion   ; pathname head.
                        ;; If bit 0 then local else network:
                        (if (setq flags (= (logand flags 1) 1))
                            ;; Go to the base pathname on the local
system at
                            ;; the offset specified as a dword at offset
10h:
                            (forward-char
                             (ls-lisp-buffer-substring-as-int (+ (point)
?\x10) 4))
                          ;; Go to the network volume table at the
offset
                          ;; specified as a dword at offset 14h:
                          (forward-char
                           (ls-lisp-buffer-substring-as-int (+ (point)
?\x14) 4))
                          ;; Go to the network share name at offset 14h:
                          (forward-char ?\x14))
                        (buffer-substring (point) (1- (search-forward
"\0")))))
                     (tail              ; Get the remaining pathname
tail
                      (progn            ; specified as a dword at
                        (forward-char   ; offset 18h.
                         (ls-lisp-buffer-substring-as-int (+ (point)
?\x18) 4))
                        (buffer-substring (point) (1- (search-forward
"\0"))))))
                 (expand-file-name      ; Convert \ to /, etc.
                  (concat head
                          ;; Network share name needs trailing \ added:
                          (unless (or flags (string= tail "")) "\\")
                          tail))))))))))
); redefine
(add-hook 'dired-load-hook 'swift-after-dired)



--
Unsubscribe info:      http://cygwin.com/ml/#unsubscribe-simple
Bug reporting:         http://cygwin.com/bugs.html
Documentation:         http://cygwin.com/docs.html
FAQ:                   http://cygwin.com/faq/



-------------------- End of forwarded message --------------------

-- 
http://tiny-tools.sourceforge.net/
Swatch  @time http://www.ryanthiessen.com/swatch/resources.htm
Convert @time http://www.mir.com.my/iTime/itime.htm