;; w32utils.el --- -*- coding: iso-8859-1-unix -*-
;; Copyright 2009 Vincent Belaïche
;;
;; Author: Vincent Belaïche <address@hidden>
;; Version: $Id: w32utils.el,v 0.0 2009/03/22 10:39:33 Vincent Exp $
;; Keywords:
;; X-URL: not distributed yet

;;
;; This software is governed by the CeCILL license under French law and
;; abiding by the rules of distribution of free software.  You can  use,
;; modify and/ or redistribute the software under the terms of the CeCILL
;; license as circulated by CEA, CNRS and INRIA at the following URL
;; "http://www.cecill.info".
;;
;; As a counterpart to the access to the source code and  rights to copy,
;; modify and redistribute granted by the license, users are provided only
;; with a limited warranty  and the software's author,  the holder of the
;; economic rights,  and the successive licensors  have only  limited
;; liability.
;;
;; In this respect, the user's attention is drawn to the risks associated
;; with loading,  using,  modifying and/or developing or reproducing the
;; software by the user in light of its specific status of free software,
;; that may mean  that it is complicated to manipulate,  and  that  also
;; therefore means  that it is reserved for developers  and  experienced
;; professionals having in-depth computer knowledge. Users are therefore
;; encouraged to load and test the software's suitability as regards their
;; requirements in conditions enabling the security of their systems and/or
;; data to be ensured and,  more generally, to use and operate it in the
;; same conditions as regards security.
;;
;; The fact that you are presently reading this means that you have had
;; knowledge of the CeCILL license and that you accept its terms.
;;
;;; Commentary:

;;

;; Put this file into your load-path and the following into your ~/.emacs:
;;   (require 'w32utils)

;;; Code:

(provide 'w32utils)
(declare-function message-fetch-field "message" (header &optional not-all))
(declare-function mml-parse "mml" )



;;;;##########################################################################
;;;;  User Options, Variables
;;;;##########################################################################
(defgroup
  w32utils
  nil
  "Customization of w32utils package"
  :group 'emacs)

(defgroup
  w32utils-paths
  nil
  "Customization of w32utils package for manipulating paths"
  :group 'w32utils)

(defgroup
  w32utils-urls
  nil
  "Customization of w32utils package for manipulating URL"
  :group 'w32utils)

(defgroup
  w32utils-bash
  nil
  "Customization of w32utils package for using MSYS bash under MSWindows."
  :group 'w32utils)

(defgroup
  w32utils-ms-outlook-send
  nil
  "Personnalistion du paquet w32utils pour envoyer des courrier avec MS-Outlook."
  :group 'w32utils)


(defcustom w32utils-bash-home
  (concat "C:/msys/1.0/home/" (user-login-name) "/")
  "Répertoire de domiciliation de bash."
  :type 'directory
  :group 'w32utils-bash
  :set (lambda (var val)
	 (set-default var val)
	 (setenv "ENV" (concat val ".bash_profile")))
   )

(defcustom w32utils-shell-file-name
  "C:/msys/1.0/bin/bash"
  "File that holds the bash shell program."
  :type 'file
  :group 'w32utils-bash
  )

(defcustom w32utils-shell-buffer-name
  "*bash*"
  "Name of buffers for bash shell mode."
  :type 'string
  :group 'w32utils-bash
  )

(defcustom w32utils-process-coding-system
  'windows-1252-unix
  "Coding system used to communicate with bash."
  :type '(choice
	  (const :tag "Disable `w32utils-process-coding-scheme',\
 coding scheme will be based on\
 `process-coding-system-alist'" nil)
	  (coding-system :tag "Specify coding system for\
 encoding to and decoding from bash")
	  (cons :tag "Specify coding system for decoding from\
 bash" coding-system
		:tag "Specify coding system for encoding to bash"
		coding-system))
  :group 'w32utils-bash )


(defcustom w32utils-drives
  nil
  "List of association of drive letter to drive path"
  :type '(repeat
	  (cons (character :tag "Drive letter: ")
		(directory :tag "Drive network path: "))
	  )
  :group 'w32utils-paths
  )

(defcustom w32utils-add-suffix
  nil
  "Surcharche la variable `comint-completion-addsuffix'"
  :type '(choice
	  (const :tag "Utiliser la variable `comint-completion-addsuffix'" nil)
	  (const :tag "Ajouter /" t)
	  (cons :tag "Paire de suffixe"
		(string :tag "Suffixe pour Répertoire")
		(string :tag "Suffixe pour Fichier"))
	  )
  :group 'w32utils-path
  )

(defcustom w32utils-ms-outlook-temp-dir
  (let ((fn (or (getenv "TEMP") (getenv "TMP"))))
    (and (stringp fn) (file-name-as-directory fn)))
  "Chemin du répertoire où sont stockés les script VBScript
servant à l'envoi des courriels via MSOutlook."
  :type 'directory
  :group 'w32utils-ms-outlook-send)

(defvar w32utilis-ms-outlook-send-nb -1
  "Numéro détrompeur entre plusieurs script VBScript")

(defcustom w32utils-ms-outlook-action
  :display
  "Sélectionne l'action à faire sur les messages Outlook: afficher
et laisser l'utilisateur cliquer sur envoi, ou bien envoyer
directement."
  :type '(choice
	 (const :tag "Afficher sans envoyer" :display)
	 (const :tag "Envoyer" :display))
  :group 'w32utils-ms-outlook-send)


(defcustom w32utils-ms-outlook-format
  :plain
  "Selectionne le format du courrier envoyé. Note: ceci n'entraine pas
d'exportation au format HTML du corps du message."
  :type '(choice
	 (const :tag "Texte brut" :plain)
	 (const :tag "HTML" :html))
  :group 'w32utils-ms-outlook-send)


;; settings for MinGW
(setenv "ENV" (concat w32utils-bash-home ".bash_profile"))

(defun w32utils-get-os-type (&optional force-os)
  (cond
   ((natnump force-os)
    (cond ((= force-os 0) 'dos)
	  ((= force-os 1) 'bash)
	  (t nil)))
   ((string-match "\\(/sh\\|/bash\\)" cur-proc-n) 'bash)
   ((string-match "\\(/cmdproxy.exe\\)" cur-proc-n) 'dos)
   (t nil)))

(defun w32utils-refresh-default-directory (&optional force-os)
  "Resynchronise the variable `default-directory' when it is not
longer in line with the current directory, so that completion
works well again. Maybe invoked by
`\\[w32utils-refresh-default-directory]'.

Current OS (bash or dos) is detected automatically based on the
process command associated to the buffer. This works in most
cases, unless you start a subshell explicitely (e.g. type sh.exe
in a dos console). In such a case the argument FORCE-OS can be
used to force the os detection as follows:

0 => DOS
1 => BASH
"
  (interactive "P")
  (let* (cmd-pwd-send-point ; point du tampon où la commande pwd est envoyée
					;(p (point))
	 (cur-proc (get-buffer-process (current-buffer)))
	 (cur-filter (process-filter cur-proc))
	 (cur-proc-n (car (process-command cur-proc)))
	 proc-output-string; to save the the output of command providing current directory
	 (os-type (w32utils-get-os-type force-os))
	 cur-cmd
	 (msg
	  (concat (symbol-name os-type) " refresh default directory ..."))
	 cmd-start
	 cmd-point-offset
	 (cmd-pwd
	  (cond
	   ((eq os-type 'bash) "pwd -W\n")
	   ((eq os-type 'dos) "echo \"%CD%\"\n")
	   (t nil)));
	 )
    (unless cur-proc
      (error "Current buffer has no process"))
    (unless os-type
      (error "Can't detect OS type"))
    ;; get start of cmd under edition, if any
    (save-excursion
      (cond
       ((and (boundp 'comint-last-prompt-overlay) (overlayp comint-last-prompt-overlay))
	(setq cmd-start (overlay-end comint-last-prompt-overlay)))
       (t
	(beginning-of-line)
	(setq cmd-start (point)))))
    ;; save command under edition
    (when cmd-start
      (setq cmd-pwd-send-point (point))
      (let ((pm (point-max)))
	(goto-char pm)
	(setq cmd-point-offset (- pm cmd-pwd-send-point))
	(setq cur-cmd (buffer-substring cmd-start pm))
	(delete-region cmd-start pm)))
    ;; run pwd | sed to get actual current directory
    (message msg)
    (message "sending >%s" cmd-pwd)
    (set-process-filter
     cur-proc
     (lambda (proc output-str)
       (message "coucou!=>%s<=" output-str)
       ;; cas du DOS, le processus renvoie trois lignes
       ;; ligne 1 : l'écho de la commande
       ;; ligne 2 : la réponse (ce qu'on veut)
       ;; ligne 3 : l'invite (prompt)
       ;; cas de BASH, le processus ne renvoie que les lignes 2 et 3
       (setq proc-output-string
	     (nth
	      (cond
	       ((eq os-type 'dos) 1)
	       ((eq os-type 'bash) 0))
	      (split-string output-str "[\n\r]+")))
       (and cur-filter
	    (funcall cur-filter proc output-str))))
    (comint-send-string cur-proc cmd-pwd)
    ;; get output and evaluate expression if any
    (cond
     ((accept-process-output cur-proc 1)
      (set-process-filter cur-proc cur-filter); restore filter.
      (if (and
	   proc-output-string
	   (progn
	     ;; élimine les guillemets anglais, s'il y en a.
	     (when (and (eq os-type 'dos) (string-match "\\`\"\\(.+\\)\"\\'" proc-output-string))
	       (setq proc-output-string (match-string 1 proc-output-string)))
	     (null (string= proc-output-string ""))))
	  (progn
	    (cd (file-name-as-directory proc-output-string))
	    (message "%s done" msg))
	(message "%s failed" msg)))
     (t (message "%s timed out" msg)))
    ;; restore command under edition if any
    (when cur-cmd
      (insert cur-cmd)
      (goto-char (- (point) cmd-point-offset)))))

(defun bash (&optional buffer)
  "Create a new bash buffer or activate any existing one. A
prefix argument forces creation of a new buffer."
  (interactive
   (list
    (and current-prefix-arg
	 (read-buffer "Shell buffer: "
		      (generate-new-buffer-name w32utils-shell-buffer-name)))))

  (let ((shell-file-name w32utils-shell-file-name))
    (shell (or buffer w32utils-shell-buffer-name)))
  (when w32utils-add-suffix
    (set (make-local-variable 'comint-completion-addsuffix) w32utils-add-suffix))
  (when w32utils-process-coding-system
    (set-buffer-process-coding-system
     (cond
      ((symbolp w32utils-process-coding-system) w32utils-process-coding-system)
      ((consp w32utils-process-coding-system) (car w32utils-process-coding-system)))
     (cond
      ((symbolp w32utils-process-coding-system) w32utils-process-coding-system)
      ((consp w32utils-process-coding-system) (cdr w32utils-process-coding-system))))))


(defun w32utils-shell-mode-hook ()
  (define-key shell-mode-map (kbd "C-x g") 'w32utils-refresh-default-directory ) )
(add-hook 'shell-mode-hook 'w32utils-shell-mode-hook)

;;;============================================================================
;;; Filename conversion
;;;============================================================================


(defun w32utils-latex-url-text-type-quote (x)
  (let ((pos0 0) pos)
    (while (setq pos (string-match "[#\\_%]" x pos0))
      (setq x (replace-match (concat "\\" (match-string 0 x)) t t x)
	    pos0 (+ 2 pos))))
  x)

(defcustom w32utils-latex-url-text-quote-function
  'w32utils-latex-url-text-type-quote
  "Function for quoting text of LaTeX URLs."
  :type 'function
  :group 'w32utils-urls)


(defun w32utils-org-url-text-type-quote (x)
  (let ((pos0 0) pos)
    (while (setq pos (string-match "[*\\_]" x pos0))
      (setq x (replace-match (concat "\\" (match-string 0 x)) t t x)
	    pos0 (+ 2 pos))))
  x)

(defcustom w32utils-org-url-text-quote-function
  'w32utils-org-url-text-type-quote
  "Function for quoting text of Org mode URLs."
  :type 'function
  :group 'w32utils-urls)


(defun w32utils-html-url-text-type-quote (x)
  (save-match-data
    (let ((pos0 0) pos
	  (replace-al '((?& . "amp") (?< . "lt") (?> . "gt")))
	  replacement
	  )
      (while (setq pos (string-match "[&<>]" x pos0))
	(setq replacement (assq (aref (match-string 0 x) 0) replace-al)
	      x (replace-match (concat "&" replacement ";" ) t t x)
	      pos0 (+ pos 2 (length replacement))))))
  x)

(defcustom w32utils-html-url-text-quote-function
  'w32utils-html-url-text-type-quote
  "Function for quoting text of HTML mode URLs."
  :type 'function
  :group 'w32utils-urls)


(defcustom w32utils-link-prefix-overload
  nil
  "List of cons cells (PREFIX . OVERLOAD), where PREFIX and
OVERLOAD are strings such that any URL generated by function
`w32utils-/-to-\\' prefixed by PREFIX has PREFIX replaced by
OVERLOAD."
  :type '(repeat
	  (cons
	   (string :tag "Prefix")
	   (string :tag "Overload")))
  :group 'w32utils-paths)

(defvar w32utils-old-expand-file-name nil)
(unless (functionp 'w32utils-old-expand-file-name)
  (fset 'w32utils-old-expand-file-name (symbol-function 'expand-file-name)))

(defcustom w32utils-msys-base-directory
  (let ((msys (getenv "MSYS")))
    (and msys (file-name-as-directory (w32utils-old-expand-file-name msys))))
  "Répertoire de base de MSYS, sous lequel on trouve `bin' et
`etc'. Défini par défaut au contenu de la variable
d'environnement MSYS."
  :group 'w32utils-paths)

(defvar w32utils-msys-fstab-cache [ nil nil]
  "Résultat de l'analyse du fichier fstab de MSYS.

L'élément 0 est la date de dernière modification du fichier.

L'élément 1 est un liste d'élément E où \(car E) est un entier N
donnant une longueur de chemin, et \(cdr E) est une liste
d'association dont chaque élement est de la forme (K . V), ou K
est un chemin au format Linux de longueur N, et V est le chemin
correspondant dans MSWindows.")

(defun w32utils-refresh-msys-fstab-cache (&optional force-refresh ignore-errors)
  ;; quelque vérification
  (let (fstab (line-nb 0) cell-list by-len-list (l 0) next-by-len cell)
  (cond
   ((null w32utils-msys-base-directory)
    (unless ignore-errors
      (error "L'analyse de MSYS fstab est impossible car
      `w32utils-msys-base-directory' n'est pas défini.")))
   ((null (file-directory-p w32utils-msys-base-directory))
     (unless ignore-errors
      (error "L'analyse de MSYS fstab est impossible car
      `w32utils-msys-base-directory' ne pointe pas sur sur un
      répertoire.")))
   ((null (file-exists-p (setq fstab (concat w32utils-msys-base-directory "etc/fstab"))))
     (unless ignore-errors
      (error "L'analyse de MSYS fstab est impossible car
      `w32utils-msys-base-directory' ne pointe pas sur sur un
      répertoire.")))
   ((and (null force-refresh)
	 (equal (aref w32utils-msys-fstab-cache 0)
		(nth 5 (file-attributes fstab)))))
   (t
    (with-temp-buffer
      (insert-file-contents fstab)
      (goto-char (point-min))
      (while (null (eobp))
	(setq line-nb (1+ line-nb))
	(cond
	 ((looking-at "^\\s-*#"))
	 ((looking-at "^\\s-*$"))
	 (t
	  (looking-at "\\s-*")
	  (goto-char (match-end 0))
	  (cl-flet ((read-string ()
		  (let (ret)
		    (while
			(progn
			  (cond
			   ((looking-at "\"\\([^\"]*\\)\"")
			    (push (match-string-no-properties 1) ret)
			    (goto-char (match-end 0)))
			   ((looking-at "'\\([^']*\\)'")
			    (push (match-string-no-properties 1) ret)
			    (goto-char (match-end 0)))
			   ((looking-at "[^ \t\n\r]+")
			    (push (match-string-no-properties 0) ret)
			    (goto-char (match-end 0)))
			   (t nil))))
		   (apply 'concat (nreverse ret)))))
	    (let (s1 s2)
	      (if
		  (and (setq s1 (read-string))
		       (> (length s1) 0)
		       (looking-at "\\s-+")
		       (setq s2
			     (progn (goto-char (match-end 0))
				    (read-string)))
		       (> (length s2) 0))
		   (push (cons s2 s1) cell-list)
		(or ignore-errors
		    (error
		     "%s:%d: Ligne incorrecte %s"
		     fstab line-nb
		     (progn
		       (beginning-of-line)
		       (buffer-substring
			(point)
			(progn (end-of-line) (point)))))))))))
	(beginning-of-line 2)))
    ;; Ajout des associations prédéfinies
    (let ((builtin-fstab '(("/bin"     . "bin")
			   ("/usr/bin" . "bin")
			   ("/temp"    . "temp")
			   ("/etc"     . "etc"))) builtin-fstab-cell temp)
      (setq builtin-fstab
	    (mapcar (lambda (x)
		      (cons (car x) (concat w32utils-msys-base-directory (cdr x))))
		    builtin-fstab))
      (when (setq tmp (getenv "TEMP"))
	(push (cons "/tmp" (substring (file-name-as-directory tmp) 0 -1)) builtin-fstab))
      (while builtin-fstab
	(setq builtin-fstab-cell (pop builtin-fstab))
	(unless (setq cell (assoc-string (car builtin-fstab-cell) cell-list))
	  (push builtin-fstab-cell cell-list)))	)
    ;; tri par longueur de chaîne
    (setq cell-list (sort cell-list (lambda (x y) (< (length (car x)) (length (car y))))))
    (while cell-list
      (setq cell (pop cell-list))
      (when (> (length (car cell)) l)
	(and next-by-len (push (cons l next-by-len) by-len-list))
	(setq next-by-len nil
	      l (length (car cell))))
      (push cell next-by-len))
    (and next-by-len  (push (cons l next-by-len) by-len-list))
    (aset w32utils-msys-fstab-cache 0 (nth 5 (file-attributes fstab)))
    (aset w32utils-msys-fstab-cache 1 (nreverse by-len-list))))))

(w32utils-refresh-msys-fstab-cache)

(defun w32utils-new-expand-file-name (name &optional default-directory)
  (save-match-data
    (cl-flet
	((msys-expand-file-name
	  (name)
	  (let (new-name by-len-list alist l cell)
	    (if (string-match "\\`\\(/\\([a-z]\\)\\)\\(/\\|\\'\\)" name)
		(setq new-name (replace-match (concat (match-string-no-properties 2 name)
						      ":")
					      t t name 1)))
	    (setq by-len-list (aref w32utils-msys-fstab-cache 1))
	    (while (and by-len-list (null new-name))
	      (setq alist (pop by-len-list))
	      (if (> (setq l (pop alist)) (length name))
		  (setq by-len-list nil) ; casse la boucle
		(and (or (= l (length name))
			 (= ?/ (aref name l)))
		     (setq cell (assoc-string (substring name 0 l) alist))
		     (setq new-name (concat (cdr cell) (substring name l))
			   by-len-list nil))))
	    new-name)))
      (or (msys-expand-file-name name)
	  (and (stringp default-directory)
	       (msys-expand-file-name
		(concat (file-name-as-directory default-directory)
			name)))
	  (w32utils-old-expand-file-name name default-directory)))))

(defcustom w32utils-overload-expand-file-name nil
  "Booléen, mettre à `t' pour que `expand-file-name' soit
  surchargé pour prendre en charge les chemin MSYS. Voir la
  fonction `w32utils-new-expand-file-name'."
  :type 'boolean
  :set (lambda (var val)
	 (set-default var val)
	 (fset 'expand-file-name  
	       (symbol-function
		(if val  'w32utils-new-expand-file-name
		  'w32utils-old-expand-file-name))))
  :group 'w32utils)

(defconst w32utils-url-presentation-text-type-customization-type
  '(radio (const  basename)
	  (const  basename-sans-extension)
	   (const  dirname+basename)
	   (list (const user-defined) string))
  "Customization time for url presentation text type.")

(defcustom w32utils-latex-url-presentation-text-type
  '(user-defined "link")
  "Defines how a link is presented. "
  :type w32utils-url-presentation-text-type-customization-type
  :group 'w32utils-urls)

(defcustom w32utils-org-url-presentation-text-type
  '(user-defined "link")
  "Defines how a link is presented in Org mode. "
  :type w32utils-url-presentation-text-type-customization-type
  :group 'w32utils-urls)

(defcustom w32utils-html-url-presentation-text-type
  '(user-defined "link")
  "Defines how a link is presented in HTML. "
  :type w32utils-url-presentation-text-type-customization-type
  :group 'w32utils-urls)



(defvar w32utils-dired-buffer
  nil
  "Variable to dired buffer from which w32utils-filename-org is to be provided." )

(defvar w32utils-filename-org
  nil
  "Variable set to to filename to be converted locally to a
  w32utils filename conversion buffer." )
(defvar w32utils-filename-dest
  nil
  "Variable set to filename to be converted locally to a
  w32utils filename conversion buffer." )

(defvar w32utils-filename-conv-display-end-mark
  nil
  "Variable set to a mark that is end of display zone in w32bask
  filename conversion buffer." )

(defvar w32utils-quit-handler nil
  "Action performed when the filename conversion buffer is quitted"  )

(defvar w32utils-filename-concat-comma nil
  "Comma separator, to be redefined locally to filename
  conversion buffer." )

(defun w32utils-get-drive (drive)
  (cdr-safe (assq drive w32utils-drives)))

(defun w32utils-filename-conv-check-buffer (arg &optional ignore-dired-is-dead)
  (cond
   ((null arg) (setq arg 0))
   ((eq arg '-) (setq arg nil)))
  (cond
   ((bufferp w32utils-dired-buffer)
    (unless  (or ignore-dired-is-dead
		 (buffer-live-p w32utils-dired-buffer))
      (error "Pointed at Dired buffer is no longer alive."))
    (unless w32utils-filename-dest
      (set (make-local-variable 'w32utils-filename-dest) nil))
    (set (make-local-variable 'w32utils-filename-org)
	   (with-current-buffer w32utils-dired-buffer
	     (if arg
		 (cond ((zerop (prefix-numeric-value arg))
			(dired-get-marked-files))
		       ((consp arg)
			(dired-get-marked-files t))
		       (t
			(dired-get-marked-files
			 'no-dir (prefix-numeric-value arg))))
	       (dired-get-marked-files 'no-dir)))))
   ((consp w32utils-filename-org)
    ;; do nothing
    )
   (t
    (error "Not in filename conversion buffer"))))

(defun w32utils-filename-to-string (&optional arg)
  "Convert a filename to a \\ separated string, add a final `\\' if the filename is a directory."
  (interactive "P")
  (w32utils-filename-conv-check-buffer arg)
  (dolist (v w32utils-filename-org)
    (when (file-directory-p v)
      (setq v (concat v "/")))
    (push (mapconcat 'identity (split-string v "/") "\\")
	  w32utils-filename-dest))
  (setq w32utils-filename-dest (nreverse w32utils-filename-dest)))


(defun w32utils-filename-to-c-string (&optional arg)
  "Convert a filename a \\\\ separated string"
  (interactive "P")
  (w32utils-filename-conv-check-buffer arg)
  (dolist (v w32utils-filename-org)
    (push
     (mapconcat 'identity (split-string v "/") "\\\\")
     w32utils-filename-dest))
  (setq w32utils-filename-dest (nreverse w32utils-filename-dest)))


(defun w32utils-filename-to-url (&optional arg)
  "Convert a filename to an URL."
  (interactive "P")
  (w32utils-filename-conv-check-buffer arg)
  (let* ((to-xdigit (lambda (x) (if (< x 10) (+ ?0 x) (+ 55 x) )))
	 host)
    (dolist (v w32utils-filename-org)
      (let (w)
	(setq w
	      (apply 'string
		     (apply 'append
			    (mapcar
			     (lambda (x)
			       (if (or (<= x 31)
				       (>= x 128)
				       (memq x '( 32 34 35 36
						     37 38 43 44 ;47
						     58
						     59 60 61 62 63 64
						     91 92 93 94 96
						     123 124 125 126
						     )))
				   (list ?%   (funcall to-xdigit (logand (/ (mod x 256) 16) 15))
					 (funcall to-xdigit (logand x 15)))
				 (list x)))
			     v))))
	(if (and (string-match "\\`\\([A-Z]\\):/" v)
		 (setq host (w32utils-get-drive (aref (match-string 1 v) 0))))
	    (setq w (substring w 5))
	  (setq host "//localhost/"))
	(setq w
	      (concat "file:" host w))
	(let ((l w32utils-link-prefix-overload)
	      x
	      prefix
	      lenpfx
	      (lenw (length w))
	      overload)
	  (while l
	    (setq x (car l)
		  l (cdr l)
		  prefix (car x)
		  lenpfx (length prefix))
	    (when (and
		   (>= lenw lenpfx)
		   (string= (substring w 0 lenpfx)
			   prefix))
	      (setq w (concat (cdr x)
			      (substring w lenpfx))
		    l nil))))
	(push w w32utils-filename-dest)))
    (setq w32utils-filename-dest (nreverse w32utils-filename-dest))))


(defun w32utils-filename-to-latex-url (&optional arg)
  "Convert filenames to a LaTeX URL based on hyperref package."
  (interactive "P")
  (w32utils-filename-to-url arg)
  (let ((ld w32utils-filename-dest)
	(lo w32utils-filename-org)
	e o (p 0) np)
    (while ld
      (setq e (car ld)
	    o (car lo))

      (while (setq p (string-match "\\([%#~]\\)" e p))
	(setq e (replace-match "\\\\\\1" t nil e))
	(setq p (+ 2 p)))
      (setq e (concat
	       "\\href {" e "}{"
	       (w32utils-make-url-text o
				       w32utils-latex-url-presentation-text-type
				       w32utils-latex-url-text-quote-function)
	       "}"))
      (setcar ld e)
      (setq ld (cdr ld)
	    lo (cdr lo)) )))

(defun w32utils-make-url-text (text text-type quotation-function)
  (cond
   ((eq text-type 'basename)
    (funcall quotation-function (file-name-nondirectory text)))
   ((eq text-type 'basename-sans-extension)
    (funcall quotation-function
	     (file-name-sans-extension
	      (file-name-nondirectory text))))
   ((eq text-type 'dirname+basename)
    (funcall quotation-function text))
   ((eq (car-safe text-type) 'user-defined)
    (cadr text-type))
   (t "")))

(defun w32utils-filename-to-html-url (&optional arg)
  "Convert filenames to a HTML URL based."
  (interactive "P")
  (w32utils-filename-to-url arg)
  (let ((ld w32utils-filename-dest)
	(lo w32utils-filename-org)
	e o (p 0) np)
    (while ld
      (setq e (car ld)
	    o (car lo))

      (setq e (concat
	       "<a href=\"" e "\">"
	       (w32utils-make-url-text o
				       w32utils-html-url-presentation-text-type
				       w32utils-html-url-text-quote-function)
	       "</a>"))
      (setcar ld e)
      (setq ld (cdr ld)
	    lo (cdr lo)) )))

(defun w32utils-filename-to-org-url (&optional arg)
  "Convert filenames to a Org URL based on hyperref package."
  (interactive "P")
  (w32utils-filename-to-url arg)
  (let ((ld w32utils-filename-dest)
	(lo w32utils-filename-org)
	e o (p 0) np)
    (while ld
      (setq e (car ld)
	    o (car lo))

      (setq e (concat
	       "[[" e "]["
	       (w32utils-make-url-text o
				       w32utils-org-url-presentation-text-type
				       w32utils-org-url-text-quote-function)
	       "]]"))
      (setcar ld e)
      (setq ld (cdr ld)
	    lo (cdr lo)) )))


(defun w32utils-customize-url-text (symbol)
  "Customize the presentation text part for some mode URL (like LaTeX, Org, or HTML).
symbol is the customization variable corresponding to the concerned mode."
  (customize-variable symbol) )

(defun w32utils-filename-quit-action ()
  )
(defun w32utils-filename-quit-\; ()
  (interactive)
  (setq w32utils-filename-concat-comma ";")
  (funcall w32utils-quit-handler))

(defun w32utils-filename-quit ()
  "Convert a filename a \\\\ separated string"
  (interactive)
  (funcall w32utils-quit-handler))

(defconst w32utils-filename-conv-keymap
  (let ((km (make-sparse-keymap)))
    (define-key km [?C] 'w32utils-filename-to-c-string)
    (define-key km [?h] 'w32utils-filename-to-html-url)
    (define-key km [?l] 'w32utils-filename-to-latex-url)
    (define-key km [?o]  'w32utils-filename-to-org-url)
    (define-key km [?q] 'w32utils-filename-quit)
    (define-key km [?\;] 'w32utils-filename-quit-\;)
    (define-key km [?s] 'w32utils-filename-to-string)
    (define-key km [?u] 'w32utils-filename-to-url)
    (define-key km [?c]
        (let ((km (make-sparse-keymap)))
	  (define-key km [?h] (lambda () (interactive)
				(w32utils-customize-url-text 'w32utils-html-url-presentation-text-type)))
	  (define-key km [?l] (lambda () (interactive)
				(w32utils-customize-url-text 'w32utils-latex-url-presentation-text-type)))
	  (define-key km [?o] (lambda () (interactive)
				(w32utils-customize-url-text 'w32utils-org-url-presentation-text-type)))
	  km))
    (define-key km [?g]
        (let ((km (make-sparse-keymap)))
	  (define-key km [?h] 'w32utils-rotate-html-presentation-text-type)
	  (define-key km [?l] 'w32utils-rotate-latex-presentation-text-type)
	  (define-key km [?o] 'w32utils-rotate-org-presentation-text-type)
	    km))
    km)
  "Keymap local to the w32utils filename conversion buffer")

(defun w32utils-filename-open-conv-buffer ()
  ""
  )

(defun w32utils-kill-filename-conv-buffer ()
  (let* ((b (current-buffer))
	 (w (get-buffer-window b))
	 (dired-buffer w32utils-dired-buffer))
    (when w
      (delete-window w))
    (when (buffer-live-p dired-buffer)
      (set-buffer dired-buffer)
      (unless (get-buffer-window dired-buffer)
	(switch-to-buffer dired-buffer))
      (bury-buffer b)
      (kill-buffer b))))


(defun w32utils-display-current-text-type
  (current-presentation-text-type beg-mark end-mark)
  (let ((save-buffer-read-only buffer-read-only))
    (setq buffer-read-only nil)
    (delete-region beg-mark end-mark)
    (cond
     ((symbolp current-presentation-text-type)
      (save-excursion
	(goto-char beg-mark)
	(insert (symbol-name current-presentation-text-type))))
     ((consp current-presentation-text-type)
      (save-excursion
	(goto-char beg-mark)
	(insert (symbol-name (car current-presentation-text-type))
		" "
		(prin1-to-string  (cadr current-presentation-text-type))))))
    (setq buffer-read-only save-buffer-read-only)))

(defun w32utils-rotate-presentation-text-type
  (current-presentation-text-type beg-mark end-mark)
  (let ((l (cdr w32utils-url-presentation-text-type-customization-type))
	lelt
	elt
	elt-id
	elt-is-const
	(val (symbol-value current-presentation-text-type))
	val-id)
     (while l
       (setq
	lelt l
	elt (car lelt)
	elt-id (cond
		((eq (car elt) 'const)
		 (setq elt-is-const t)
		 (cadr elt))
		((and (eq (car elt) 'list)
		      (eq (caadr elt) 'const))
		 (setq elt-is-const nil)
		 (cadadr elt))
		(t nil))
	val-id (cond
		((symbolp val) val)
		((consp val) (car val))
		(t t))
	l   (cdr l))
       (if (eq elt-id val-id)
	   (setq l nil)
	 (setq elt-id nil)))
     (when elt-id
       (setq elt (if (cdr lelt) (cadr lelt) (cadr w32utils-url-presentation-text-type-customization-type))
	     elt-id (cond
		     ((eq (car elt) 'const)
		      (setq elt-is-const t)
		      (cadr elt))
		     ((and (eq (car elt) 'list)
			   (eq (caadr elt) 'const))
		      (setq elt-is-const nil)
		      (cadadr elt))
		     (t nil)))
       (set current-presentation-text-type
	    (if elt-is-const elt-id
	      	 (let* ((default "link")
			(prompt "Enter user-defined (link): "))
		   (list 'user-defined (read-from-minibuffer prompt nil nil nil nil default)))))))
  (w32utils-display-current-text-type
   (symbol-value current-presentation-text-type) beg-mark end-mark))


(defun w32utils-rotate-latex-presentation-text-type ()
  (interactive)
  (w32utils-rotate-presentation-text-type
   'w32utils-latex-url-presentation-text-type
   w32utils-latex-presentation-text-type-beg-mark
   w32utils-latex-presentation-text-type-end-mark))

(defun w32utils-rotate-org-presentation-text-type ()
  (interactive)
  (w32utils-rotate-presentation-text-type
   'w32utils-org-url-presentation-text-type
   w32utils-org-presentation-text-type-beg-mark
   w32utils-org-presentation-text-type-end-mark))

(defun w32utils-rotate-html-presentation-text-type ()
  (interactive)
  (w32utils-rotate-presentation-text-type
   'w32utils-html-url-presentation-text-type
   w32utils-html-presentation-text-type-beg-mark
   w32utils-html-presentation-text-type-end-mark))




(defun w32utils-concat-as-killed ()
  "Action to be performed when the filename conversion buffer is quitted"
  (w32utils-filename-conv-check-buffer nil t)
  (when w32utils-filename-dest
    (kill-new (mapconcat 'identity w32utils-filename-dest (or w32utils-filename-concat-comma " ")) t))
  (w32utils-kill-filename-conv-buffer))

(defvar w32utils-html-presentation-text-type-beg-mark nil)
(defvar w32utils-html-presentation-text-type-end-mark nil)
(defvar w32utils-latex-presentation-text-type-beg-mark nil)
(defvar w32utils-latex-presentation-text-type-end-mark nil)
(defvar w32utils-org-presentation-text-type-beg-mark nil)
(defvar w32utils-org-presentation-text-type-end-mark nil)
(defun w32utils-insert-url-keybinding-text-and-presentation-text-type
  (keybinding-text
   current-presentation-text-type
   beg-mark
   end-mark)
  (insert keybinding-text " [")
  (set (make-local-variable beg-mark) (point-marker))
  (set (make-local-variable end-mark) (point-marker))
  (insert "]\n")
  (set-marker-insertion-type (symbol-value end-mark) t)
  (w32utils-display-current-text-type
   current-presentation-text-type
   (symbol-value beg-mark)
   (symbol-value end-mark)))


(defun w32utils-/-to-\\ (&optional conversion-type)
  "Replace all the / character in the scratchpad into \\ characters.

When CONVERSION-TYPE is omitted or 0 just do this.

When CONVERSION-TYPE is non-nil and is not an integer or is 1, /
characters are replaced by \\\\, so that the result can be pasted
into a string Lisp or C code.

When CONVERSION-TYPE is 2, then pre-pend the string \"file://localhost/\"

Otherwise do nothing.
"
  (interactive "P")

  (let ((current-kill (current-kill 0 t)))
    (cl-flet ((wrap-converter (current-kill converter)
	    (let ((w32utils-filename-org (list current-kill))
		  w32utils-filename-dest)
	      (funcall converter)
	      (car w32utils-filename-dest))))
      (cond
       ;;
       ((and
	 (null conversion-type)
	 (derived-mode-p 'dired-mode))
	(setq current-kill nil)
	(let ((dired-buffer (current-buffer))
	      (conversion-buffer (generate-new-buffer "*Filename conversion*")))
	    (switch-to-buffer-other-window conversion-buffer t)
	    (insert "\
\[C] c-string: / -> \\\\\n")
	    (w32utils-insert-url-keybinding-text-and-presentation-text-type
	     "[h] HTML URL"
	     w32utils-html-url-presentation-text-type
	     'w32utils-html-presentation-text-type-beg-mark
	     'w32utils-html-presentation-text-type-end-mark)
	    (w32utils-insert-url-keybinding-text-and-presentation-text-type
	     "[l] Latex URL"
	     w32utils-latex-url-presentation-text-type
	     'w32utils-latex-presentation-text-type-beg-mark
	     'w32utils-latex-presentation-text-type-end-mark)
	    (insert "[q] quit
\[;] quit forcing separator to ;
\[s] string: / -> \\\n")
	    	    (w32utils-insert-url-keybinding-text-and-presentation-text-type
	     "[o] Org URL"
	     w32utils-org-url-presentation-text-type
	     'w32utils-org-presentation-text-type-beg-mark
	     'w32utils-org-presentation-text-type-end-mark)
		    (insert "[u] URL
\[c h] customize HTML URL text
\[c l] customize LaTeX URL text
\[c o] customize Org URL text\n"
	     )
	    (set (make-local-variable 'w32utils-dired-buffer) dired-buffer)
	    (set (make-local-variable 'w32utils-quit-handler) 'w32utils-concat-as-killed)
	    (set (make-local-variable 'w32utils-filename-concat-comma) nil)
	    (use-local-map w32utils-filename-conv-keymap)
	    (setq buffer-read-only t);
	    ))
       ;;
       ((null (stringp current-kill)) (setq current-kill nil))
       ;;
       ((eq conversion-type 0)
	(setq current-kill (wrap-converter current-kill 'w32utils-filename-to-string)))
       ;;
       ((or
	  (and conversion-type (null (integerp conversion-type)))
	  (eq conversion-type 1))
	(setq current-kill (wrap-converter current-kill 'w32utils-filename-to-c-string)));
       ;;
       ((eq conversion-type 2)
	(setq current-kill (wrap-converter current-kill 'w32utils-filename-to-url)));
       ;;
       (t (setq current-kill nil)))
      (when current-kill
	(kill-new current-kill t)))))

(defun w32utils-vb-stringize (str)
  (concat "\""
	  (mapconcat 'identity (split-string str "\"") "\"\"")
	  "\""))

(defun w32utils-send-it ()
  "Mail sending function to send emails via MSOutlook"
  (with-current-buffer mailbuf
    (let ((header-boundary
	   (save-excursion
	     (goto-char (point-min))
	     (or
	      (re-search-forward "--text follows this line--" nil t)
	      (point-max)))))
      (cl-flet
	  ((fetch-field
	    (field-id)
	    (save-restriction
	      (narrow-to-region (point-min) header-boundary)
	      (message-fetch-field field-id)))
	   (get-field
	    (field-descriptor)
	    (cdr (assoc-string  (or (fetch-field (pop field-descriptor))
				    (pop field-descriptor))
				field-descriptor)))
	   (set-text-field
	    (x)
	    (let ((field (mapcar (lambda (x) (concat (w32utils-vb-stringize x)
						     " & sCR_LF"))
				 (split-string (or x "") "\n")))
		  i)
	      (while field
		(insert "\nsField = " (if i "sField & " ""))
		(setq i 0)
		(while (and (< i 3) field)
		  (insert (if (= 0 i) "" " _\n\t& ") (pop field))
		  (setq i (1+ i))))));
	   (html-escape
	    (x)
	    (let ((p1 0)
		  p2
		  (len (length x))
		  l)
	      (while (and (< p1 len)
			  (setq p2 (string-match "[&<>]" x p1)))
		(and
		 (> p2 p1)
		 (push (substring x p1 p2) l))
		(push (cdr (assoc-string (match-string 0 x)
					 '( ( "&" . "&amp;")
					    ( ">" . "&gt;")
					    ( "<" . "&lt;"))))
		      l)
		(setq p1 (1+ p2)))
	      (and (< p1 len)
		   (push (substring x p1) l))
	      (apply 'concat (nreverse l))));
	   )
	(let* ((vbscript-file  (concat w32utils-ms-outlook-temp-dir
				       (format-time-string "W32utils-%Y%m%dT%H%M%S")
				       (format "-%04d.vbs" (setq w32utilis-ms-outlook-send-nb
								 (1+ w32utilis-ms-outlook-send-nb)))))
	       (vbscript (save-excursion (find-file vbscript-file))))

	  (with-current-buffer vbscript
	    (insert "Dim oOutlookApp, oMailItem
Dim lPos
Const iOL_MAIL_ITEM = 0
Const iOL_FORMAT_HTML = 2
Const iOL_FORMAT_PLAIN = 1
Const iOL_IMPORTANCE_HIGH = 2
Const iOL_IMPORTANCE_NORMAL = 1
Const iOL_IMPORTANCE_LOW = 0
Const iOL_BY_VALUE = 1
Set oOutlookApp = CreateObject(\"Outlook.Application\")
Set oMailItem = oOutlookApp.CreateItem(iOL_MAIL_ITEM)
Const sLIST_SEPARATOR = \";\"
Dim sCR_LF
sCR_LF = Chr(13) & Chr(10)
Dim sField"
		    )
	    (save-excursion
	      (insert "
' Local Variables:
' coding: windows-1252-dos
' End:
"	  )))

	  (dolist (header
		   '(
		     ["to"
		      "To" :comma-separated-list fetch-field 1]
		     ["cc"
		      "Cc" :comma-separated-list fetch-field 1]
		     ["subject"
		      "Subject" :plain fetch-field 1]
		     [("importance" "normal"
		       ("high" . "iOL_IMPORTANCE_HIGH")
		       ("normal" . "iOL_IMPORTANCE_NORMAL"))
		      "Importance" :direct get-field 1]
		     ))
	    (let ((header-field (funcall (aref header 3) (aref header 0)))
		  i)
	      (when header-field
		(setq header-field
		      (case (aref header 2)
			((:comma-separated-list)
			 (let ((hf
				(mapcar (lambda (x)
					  (concat
					   (w32utils-vb-stringize x)
					   " & sLIST_SEPARATOR"))
					(nreverse (split-string header-field "\\s-*,\\s-*" t)))))
			   (when hf
			     ;; enlève le séparateur de liste sur le dernier élement
			     (setcar hf (substring (car hf) 0 -18))
			     ;; remet tout à l'endroit
			     (nreverse hf))))
			((:plain)
			 (list (w32utils-vb-stringize header-field)))
			((:direct)
			 (list  header-field))
			(t
			 (mapcar 'w32utils-vb-stringize
				 (split-string header-field "\n"))))))
	      ;; on reteste header field, des fois que pendant son traitement on se soit
	      ;; aperçu qu'il faut l'omettre
	      (when header-field
		(with-current-buffer vbscript
		  (setq i nil)
		  (while header-field
		    (insert "\nsField = " (if i "sField & " ""))
		    (setq i 0)
		    (while (and (< i 3) header-field)
		      (insert (if (= 0 i) "" " _\n\t& ") (pop header-field))
		      (setq i (1+ i))))
		  (insert "\noMailItem." (aref header 1) " = sField")))))
	  ;; body and parts
	  (let (has-body
		field-name
		force-attach
		part
		(parts  (mml-parse)))
	    (setq part (car parts))
	    (let* ((contents-cell  (assq 'contents part))
		   (contents (cdr contents-cell))
		   (separator "--text follows this line--\n"))
	      (setq contents (substring contents
					(let ((from (string-match (regexp-quote separator) contents 0)))
					  (if from (+ from (length separator)) 0))))
	      (if (string-match "\\`\\(?:\n\\|\\s-\\)*\\'" contents)
		  (setq parts (cdr-safe parts))
		(setcdr contents-cell contents)
		(setcdr part
			(cons
			 (cons 'disposition "inline")
			 (cdr part)))))
	    (while parts
	      (setq part (car parts))
	      (if (eq (car part) 'part)
		  (setq part (cdr part)))
	      ;; HTML encode when part format is "text/org-mode"
	      (let* ((type-cell  (assq 'type part))
		     (type (cdr type-cell)))
		(when (string= type "text/org-mode")
		  (let* ((contents-cell  (assq 'contents part))
			 (contents (cdr contents-cell)))
		    (setcdr type-cell "text/html")
		    (with-temp-buffer
		      (insert contents)
		      (org-mode)
		      (cl-flet ((region-beginning () (point-min))
			     (region-end () (point-max))
			     (org-region-active-p () t))
			(setq contents (org-export-as-html 3 nil '(:body-only t) 'string) )
			(setcdr contents-cell contents))))))
	      (with-current-buffer vbscript
		(cond
		 ;; Body
		 ((and (null
			(or has-body
			    force-attach
			    (assq 'filename part)))
		       (string= (cdr (assq 'disposition part)) "inline"))
		  (case (intern (cdr (assq 'type part)))
		    ((text/plain)
		     (setq has-body :plain)
		     (insert "\noMailItem.BodyFormat = iOL_FORMAT_PLAIN")
		     (setq field-name "Body"))
		    ((text/html)
		     (setq has-body :html)
		     (insert "\noMailItem.BodyFormat = iOL_FORMAT_HTML")
		     (setq field-name "HTMLBody"))
		    (t (setq force-attach t)))
		  (unless force-attach
		    (setq
		     parts (cdr parts))
		    (set-text-field (cdr-safe (assq 'contents part)))
		    (insert "\noMailItem." field-name " = sField")))
		 ;; file attachment
		 ((assq 'filename part)
		  (let ((filename (cdr (assq 'filename part))))
		    (if (file-exists-p filename)
			(progn
			  (setq filename (w32utils-vb-stringize
					  (convert-standard-filename
					   (expand-file-name filename))))
			  (insert "\nCall oMailItem.Attachments.Add( _\n"
				  filename ", _\niOL_BY_VALUE, _\n1, _\n" filename ")"))
		      (error "Can't find file %s" filename)))
		  (setq parts (cdr parts)))
		 ;; subsequent text attachment
		 ((and (null
			(or force-attach
			    (assq 'filename part)))
		       (string= (cdr (assq 'disposition part)) "inline"))
		  (case (intern (cdr (assq 'type part)))
		    ((text/plain)
		     (if (eq has-body :plain)
			 (progn
			   (set-text-field (cdr-safe (assq 'contents part)))
			   (insert "\noMailItem.Body = oMailItem.Body & sCR_LF _
& \"-----------------------------------------------------------------------\" & sCR_LF _
& sField"))
		       (set-text-field (html-escape (or "" (cdr-safe (assq 'contents part)))))
		       (insert "
lPos = InStr(oMailItem.Body,\"</BODY>\")
oMailItem.HTMLBody = Left(oMailItem.HTMLBody,lPos) _
& \"<p><hr/></p><div>\" & sField & \"</div>\" & Mid(oMailItem.HTMLBody,lPos+1,10000)"
			       )))
		    ((text/html)
		     (set-text-field (cdr-safe (assq 'contents part)))
		     (when (eq has-body :plain)
		       (setq has-body :html)
		       (insert "\noMailItem.BodyFormat = iOL_FORMAT_HTML"))
		     (insert "lPos = InStr(oMailItem.Body,\"</BODY>\")
oMailItem.HTMLBody = Left(oMailItem.HTMLBody,lPos) _
& \"<p><hr/></p><div>\" & sField & \"</div>\" & Mid(oMailItem.HTMLBody,lPos+1,10000)"))
		    (t (setq force-attach t)))
		  (setq parts (cdr parts)))

		 (t (error "Can't interpret part %S" part))))))
	  ;; display or send
	  (with-current-buffer vbscript
	    (case w32utils-ms-outlook-action
	      ((:display)
	       (insert "\noMailItem.Display"))
	      ((:send
		(insert "\noMailItem.Send"))))
	    (insert "\n'----------- Fin du Script ----------------\n")
	    (save-buffer))
	  (call-process
	   "cscript.exe"
	   nil nil nil
	   vbscript-file)
	  (kill-buffer vbscript))))))

;;; w32utils.el ends here