Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso/misc/volume8/pcmail/part07

Lisp/Scheme | 1989-11-03 | 51KB | 1,290 lines

Newsgroups: comp.sources.misc
subject: v08i115: pcmail part 07 of 08
From: [e-mail] (Brandon S. Allbery - comp.sources.misc)
Reply-To: [e-mail] (Croaker the Physician)

Posting-number: Volume 8, Issue 115
Submitted-by: [e-mail] (Croaker the Physician)
Archive-name: pcmail/part07

#--------------------------------CUT HERE-------------------------------------
#! /bin/sh
#
# This is a shell archive.  Save this into a file, edit it
# and delete all lines above this comment.  Then give this
# file to sh by executing the command "sh file".  The files
# will be extracted into the current directory owned by
# you with default permissions.
#
# The files contained herein are:
#
# -rw-rw-r--  1 markl       17622 Oct 30 16:57 pcmailsub.el
# -rw-rw-r--  1 markl       30775 Oct 30 15:47 pcmailsysdep.el
#
echo 'x - pcmailsub.el'
if test -f pcmailsub.el; then echo 'shar: not overwriting pcmailsub.el'; else
sed 's/^X//' << '________This_Is_The_END________' > pcmailsub.el
X;;;; GNU-EMACS PCMAIL mail reader
X
X;;  Written by Mark L. Lambert
X;;  Architecture Group, Network Products Division
X;;  Oracle Corporation
X;;  20 Davis Dr,
X;;  Belmont CA, 94002
X;;
X;;  internet: [e-mail] or [e-mail]
X;;  UUCP:     {hplabs,uunet,apple}!oracle!markl
X
X;; Copyright (C) 1989 Mark L. Lambert
X
X;; This file is not officially part of GNU Emacs, but is being
X;; donated to the Free Software Foundation.  As such, it is
X;; subject to the standard GNU-Emacs General Public License,
X;; referred to below.
X
X;; GNU Emacs is distributed in the hope that it will be useful,
X;; but WITHOUT ANY WARRANTY.  No author or distributor
X;; accepts responsibility to anyone for the consequences of using it
X;; or for whether it serves any particular purpose or works at all,
X;; unless he says so in writing.  Refer to the GNU Emacs General Public
X;; License for full details.
X
X;; Everyone is granted permission to copy, modify and redistribute
X;; GNU Emacs, but only under the conditions described in the
X;; GNU Emacs General Public License.   A copy of this license is
X;; supposed to have been given to you along with GNU Emacs so you
X;; can know your rights and responsibilities.  It should be in a
X;; file named COPYING.  Among other things, the copyright notice
X;; and this notice must be preserved on all copies.
X
X;;;; global variables
X
X;;; system-defined globals
X
X(defvar pcmail-key-alist
X  '(("date" pcmail-date-less-than-p)
X    ("priority" pcmail-priority-less-than-p)
X    ("from" pcmail-from-field-less-than-p)
X    ("to" pcmail-to-field-less-than-p))
X  "Completion list of sort types.")
X
X(defvar pcmail-filter-alist
X  '(("string" (pcmail-contains-string-p pcmail-last-search)
X          (setq pcmail-last-search
X            (pcmail-read-string-default "Search string (regexp): "
X                        pcmail-last-search)))
X    ("address" (pcmail-has-address-p pcmail-last-addresses)
X           (setq pcmail-last-addresses
X             (pcmail-read-string-default "Addresses: "
X                         pcmail-last-addresses)))
X    ("attribute" (pcmail-contains-attribute-p pcmail-last-filter-attr)
X         (setq pcmail-last-filter-attr
X               (pcmail-read-attr "Attribute: ")))
X    ("numeric-range" (pcmail-within-numeric-range-p pcmail-last-numeric-range)
X             (setq pcmail-last-numeric-range
X               (pcmail-read-numeric-range)))
X    ("date-range" (pcmail-within-date-range-p pcmail-last-date-range)
X          (setq pcmail-last-date-range (pcmail-read-date-range)))
X    ("interesting" (pcmail-subset-interesting-message-p))
X    ("unseen" (pcmail-contains-attribute-p "unseen"))
X    ("unanswered" (not (pcmail-contains-attribute-p "answered")))
X    ("todays" (pcmail-within-date-range-p (list pcmail-today pcmail-today))
X          (setq pcmail-today (pcmail-string-to-date-triple)))
X    ("all" t))
X  "List of filter names, expressions, and setup functions.  When using
Xa particular filter, the setup function (if non-NIL) is run through
Xeval to set up any arguments needed by the filter.  Then each message
Xin the folder is applied to the filter expression.  The variable
Xpcmail-current-tested-message is bound to the absolute number of the
Xmessage being tested before the function is called.  This allows the
Xfunction to access the current absolute message number without
Xrequiring that it do so.  The filter expression is run through eval
Xbecause the expression arguments must be evaluated at filter time and
Xcan change on successive applications of the filter.  For each message
Xrun through the filter, if the filter expression evaluates non-NIL,
Xthe message is included in the resulting subset.")
X
X;;; defaults
X
X(defvar pcmail-current-filter-description t
X  "Current filter expression.")
X
X(defvar pcmail-last-search nil
X  "The last regular expression given to a search command.")
X
X(defvar pcmail-last-addresses nil
X  "The last comma-separated list of addresses given to an address command.")
X
X(defvar pcmail-last-numeric-range nil
X  "The last numeric range given to a numeric range command.  A numeric range
Xis a list of two numbers, low end and high end.")
X
X(defvar pcmail-last-date-range nil
X  "The last date range given to a date range command.  A date range is a pair
Xof triples (day month year), low end and high end.")
X
X(defvar pcmail-last-filter-name nil
X  "The last filter name given to a filter command.")
X
X(defvar pcmail-last-key nil
X  "The last key name given a sort command.")
X
X;;;; subset maintenance commands and utilities
X
X;;; subset commands
X
X(defun pcmail-filter-folder (filter-name)
X  "Run the current folder through a specified filter.
XArgs: (filter-name)
X  Get a filter name and associated arguments from the minibuffer.  Completion
Xof input is permitted; input defaults to last filter name requested.  Apply
Xthe filter's predicate to each message in the current folder.  Messages
Xwhich pass through the filter comprise the current subset and are the only
Xaccessible messages in the current folder.  If the desired subset is
Xempty, do nothing.  User-defined filters are defined in your emacs
Xstartup file using the pcmail-define-filter function."
X  (interactive (list (pcmail-read-filter-name)))
X  (cond ((pcmail-build-subset-membership (pcmail-get-filter filter-name))
X     (pcmail-goto-message 1)
X     (pcmail-maybe-resummarize-folder))
X    (t
X     (error "Desired subset is empty."))))
X
X(defun pcmail-expand-subset ()
X  "Expand the current subset to include all messages in the current folder.
XArgs: none"
X  (interactive)
X  (let ((n (pcmail-make-absolute pcmail-current-subset-message)))
X    (pcmail-build-subset-membership t)
X    (pcmail-goto-message n)
X    (pcmail-maybe-resummarize-folder)))
X
X(defun pcmail-sort-folder (key-name)
X  "Sort the current subset by one of several keys.
XArgs: (key-name)
X  Sort the current subset by one of several keys.  If called interactively,
Xspecifiy a key in the minibuffer.  Completion on input is permitted; input
Xdefaults to last key given this command."
X  (interactive
X   (list (pcmail-completing-read "Key name: " pcmail-key-alist
X                 pcmail-last-key)))
X  (let ((key-entry (pcmail-search-entry-list key-name pcmail-key-alist))
X    (subset) (i 0))
X    (or key-entry
X    (error "Unknown sort key."))
X    (setq pcmail-last-key key-name)
X    (message "Sorting %s by %s..." pcmail-folder-name key-name)
X
X    ;; convert subset vector to a list since sort works only on lists
X    (while (< i (length pcmail-current-subset-vector))
X      (setq subset (cons (aref pcmail-current-subset-vector i) subset))
X      (setq i (1+ i)))
X    (setq pcmail-current-subset-vector
X      (apply 'vector (sort (nreverse subset) (nth 1 key-entry))))
X    (pcmail-maybe-resummarize-folder)
X    (message "Sorting %s by %s...done" pcmail-folder-name key-name)))
X
X(defun pcmail-define-filter (name sexp input-fn)
X  "Install a user-defined filter.
XArgs: (name sexp input-fn)
X  Create a filter entry named NAME with description SEXP and argument-input
Xfunction INPUT-FN, and install it in the assoc list pcmail-filter-alist.
XIf a filter by that name already exists, ask for overwrite permission unless
Xthe name is the special filter named \"all\", in which case overwriting is not
Xpermitted."
X  (and (string= name "all")
X       (error "Cannot overwrite the \"all\" filter"))
X  (let ((ent))
X    (and (setq ent (pcmail-filter-exists-p name))
X     (if (y-or-n-p "Filter exists; overwrite? ")
X         (setq pcmail-filter-alist (delq ent pcmail-filter-alist))
X       (error "Aborted.")))
X    (setq pcmail-filter-alist
X      (cons (list name sexp input-fn) pcmail-filter-alist))))
X
X;;; subset utility routines
X
X(defun pcmail-build-subset-membership (pred &optional start)
X  "Create a subset of messages that satisfy PRED
XArgs: (pred &optional start)
X  Using filter description PRED, build a vector of messages that
Xsatisfy that description.  If START is NIL, begin at message 1, replacing
Xthe current subset with the subset generated by this function (unless it is
Xof zero length).  If START is non-NIL, begin membership testing at message
XSTART, appending any new members to the current subset."
X  (condition-case nil
X      (let ((pcmail-current-tested-message (or start 1))
X        (subset))
X    (while (<= pcmail-current-tested-message pcmail-total-messages)
X      (and (eval pred)
X           (setq subset (cons pcmail-current-tested-message subset)))
X      (and (zerop (% (- (setq pcmail-current-tested-message
X                  (1+ pcmail-current-tested-message))
X                (or start 1))
X             pcmail-progress-interval))
X           (message "Checking filter membership...%d"
X            pcmail-current-tested-message)))
X    (and (>= (- pcmail-current-tested-message (or start 1))
X         pcmail-progress-interval)
X         (message "Checking filter membership...done (%d message%s)"
X              (length subset) (pcmail-s-ending (length subset))))
X    (and (or subset (eq pred t))
X         (setq pcmail-current-filter-description pred
X           pcmail-current-subset-vector
X           (vconcat (if start
X                pcmail-current-subset-vector
X                  (make-vector 1 0))
X                (apply 'vector (nreverse subset)))))
X    subset)
X    (quit
X      nil)))
X
X(defun pcmail-fix-expunged-subset (map)
X  "Remove expunged messages from the current subset
XArgs: (map)
X  MAP is a vector pcmail-total-messages long, with entries that are either
Xa message's post-expunge message number, or NIL if the message was expunged.
XThis function updates the current subset vector's message numbers to their
Xpost-expunged values."
X  (let ((new-subset)
X    (map-ent)
X    (i 0))
X    (unwind-protect
X    (while (< i (length pcmail-current-subset-vector))
X      (setq map-ent (aref map (aref pcmail-current-subset-vector i)))
X      (and map-ent
X           (setq new-subset (cons map-ent new-subset)))
X      (setq i (1+ i)))
X      (setq pcmail-current-subset-vector
X        (apply 'vector (nreverse new-subset))))))
X
X(defun pcmail-make-absolute (n)
X  "Return Nth subset message's absolute message number
XArgs: (n)
X  Convert relative message number N into an absolute number by indexing into
Xthe current subset membership vector.  If N is larger than the current
Xsubset length, return last subset message's absolute number.  If no absolute
Xexists, return 0."
X  (setq n (min n (pcmail-current-subset-length)))
X  (or (aref pcmail-current-subset-vector n) 0))
X
X(defun pcmail-filter-description (name)
X  "Return named filter's description.  Signal an error if filter not found
XArgs: (name)"
X  (let ((ent (pcmail-filter-exists-p name)))
X    (or ent
X    (error "No filter named %s" name))
X    (nth 1 ent)))
X
X(defun pcmail-filter-exists-p (name)
X  "If NAME is a valid filter, return its assoc list entry, else NIL.
XArgs: (name)"
X  (pcmail-search-entry-list name pcmail-filter-alist))
X
X(defun pcmail-current-subset-length ()
X  "Return the number of messages in the current subset.
XArgs: none"
X  (1- (length pcmail-current-subset-vector)))
X
X(defun pcmail-read-filter-name (&optional pr)
X  "Read a filter name from the minibuffer.
XArgs: (&optional PROMPT)
XRead a filter name from the minibuffer.  Completion is permitted; input
Xdefaults to pcmail-last-filter-name.  Signal an error if supplied filter
Xname is invalid."
X  (let ((s (pcmail-completing-read (or pr "Filter name: ") pcmail-filter-alist
X                   pcmail-last-filter-name)))
X    (or (pcmail-filter-exists-p s)
X    (error "No filter named %s." s))
X    (setq pcmail-last-filter-name s)))
X
X(defun pcmail-get-filter (filter-name)
X  "Read filter arguments and return filter predicate.
XArgs: (filter-name)
X  If FILTER-NAME is a valid filter, get its required arguments from the
Xminibuffer and return the filter predicate."
X  (let ((ent))
X    (setq ent (pcmail-filter-exists-p filter-name))
X    (and (nth 2 ent) (eval (nth 2 ent)))
X    (nth 1 ent)))
X
X;;; predicates for subset creation.  Each predicate is applied to a
X;;; message with number pcmail-current-tested-message.  This variable
X;;; is a free variable.
X
X(defun pcmail-has-address-p (recipients)
X  "Return non-NIL if current message contains the supplied address regexp .
XArgs: (recipients)
X  Convert comma-separated list of recipients RECIPIENTS into a regular
Xexpression.  Return non-NIL if message pcmail-current-tested-message
X(free variable) contains this regular expression, NIL else."
X  (setq recipients (mail-comma-list-regexp recipients))
X  (save-excursion
X    (save-restriction
X      (pcmail-narrow-to-unpruned-header pcmail-current-tested-message)
X      (or (string-match recipients (or (mail-fetch-field "to") ""))
X      (string-match recipients (or (mail-fetch-field "resent-to") ""))
X      (string-match recipients (or (mail-fetch-field "from") ""))
X      (string-match recipients (or (mail-fetch-field "resent-from") ""))
X      (string-match recipients (or (mail-fetch-field "cc") ""))
X      (string-match recipients (or (mail-fetch-field "resent-cc") ""))))))
X
X(defun pcmail-contains-attribute-p (attr)
X  "Return non-NIL if current message has attribute, NIL else.
XArgs: (attr)
X  Return non-NIL if pcmail-current-tested-message (free variable) has
XATTR set, NIL else."
X  (pcmail-has-attribute-p pcmail-current-tested-message attr))
X
X(defun pcmail-subset-interesting-message-p ()
X  "Return non-NIL is current message is interesting, NIL else.
XArgs: none"
X  (pcmail-interesting-p pcmail-current-tested-message))
X
X(defun pcmail-within-numeric-range-p (range)
X  "Return non-NIL if current message is within a numeric range, NIL else.
XArgs: (range)
X  Return non-NIL if pcmail-current-tested-message (free variable) is
Xwithin the range of absolute message numbers specified by the list RANGE,
XNIL else."
X  (and (>= pcmail-current-tested-message (nth 0 range))
X       (<= pcmail-current-tested-message (nth 1 range))))
X
X(defun pcmail-within-date-range-p (range)
X  "Return non-NIL if the current message's date is within date range, NIL else.
XArgs: (range)
X  Return non-NIL if pcmail-current-tested-message (free variable)
Xhas its date within the range of dates specified by the list RANGE, NIL else.
XDates are triples (day month year); RANGE is a pair of such triples."
X  (let ((lo (pcmail-date-triple-to-ndays (nth 0 range)))
X    (hi (pcmail-date-triple-to-ndays (nth 1 range)))
X    (date (pcmail-message-date pcmail-current-tested-message)))
X    (and date
X     (setq date (pcmail-date-triple-to-ndays date))
X     (<= date hi)
X     (>= date lo))))
X
X(defun pcmail-contains-string-p (regexp)
X  "Return non-NIL if the current message contains a specified regexp, NIL else.
XArgs: (regexp)"
X  (save-excursion
X    (save-restriction
X      (let ((case-fold-search t))
X    (pcmail-narrow-to-message pcmail-current-tested-message)
X    (re-search-forward regexp nil t)))))
X
X;;; read ranges from keyboard
X
X(defun pcmail-read-date-range ()
X  "Read a date range from the minibuffer
XArgs: none
X  Read a pair of dates from the minibuffer.  Dates must be input in the
Xform dd-mmm-yy.  Default range is pcmail-last-date-range, which is a pair of
Xdate triples, low and high.  If no default has been specified, use low value
Xas default for high value.  If the string \"begin\" is input at the low value
Xprompt, range includes all messages below high-value.  If the string \"now\"
Xis input at the high value prompt, range includes all messages above
Xlow-value.  Input becomes new value of pcmail-last-date-range."
X
X  ; our date input parser is stupid, so temporarily bind the date format to
X  ; the date input format so default input works correctly
X  (let ((lo) (hi) (pcmail-date-format "%d-%m-%y"))
X    (setq lo
X      (pcmail-read-string-default
X        "First date in range: "
X        (and (nth 0 pcmail-last-date-range)
X         (pcmail-date-triple-to-string (nth 0 pcmail-last-date-range)))
X        t))
X    (cond ((string= lo "begin")
X       (setq lo '(1 1 0)))
X      ((not (setq lo (pcmail-string-to-date-triple lo)))
X       (error "Date not dd-mmm-yy or \"begin\".")))
X    (setq hi
X      (pcmail-read-string-default
X        "Last date in range: "
X        (if (nth 1 pcmail-last-date-range)
X        (pcmail-date-triple-to-string (nth 1 pcmail-last-date-range))
X            (pcmail-date-triple-to-string lo))
X        t))
X    (cond ((string= hi "now")
X       (setq hi (pcmail-string-to-date-triple)))
X      ((not (setq hi (pcmail-string-to-date-triple hi)))
X       (error "Date not dd-mmm-yy or \"now\".")))
X    (if (> (pcmail-date-triple-to-ndays lo) (pcmail-date-triple-to-ndays hi))
X    (list hi lo)
X      (list lo hi))))
X
X(defun pcmail-read-numeric-range ()
X  "Read a numeric range from the minibuffer.
XArgs: none
X  Read a pair of absolute message numbers from the minibuffer.  Default
Xrange is value of variable pcmail-last-numeric-range, which is a pair of
Xnumbers, low and high.  If no default has been specified, use low value as
Xdefault for high value.  If the string \"first\" is input at the low
Xvalue prompt, range includes all messages below high-value.  If the string
X\"last\" is input at the high value prompt, range includes all messages above
Xlow-value.  Input becomes new value of pcmail-last-numeric-range."
X  (let ((lo)
X    (hi))
X    (setq lo
X      (pcmail-read-string-default
X        "First message in range: "
X        (and (nth 0 pcmail-last-numeric-range)
X         (int-to-string (nth 0 pcmail-last-numeric-range)))
X        t))
X    (cond ((string= lo "first")
X       (setq lo 1))
X      ((or (not (setq lo (string-to-int lo)))
X           (< lo 1)
X           (> lo pcmail-total-messages))
X       (error "Range endpoint not 1 - %d or \"first\"."
X          pcmail-total-messages)))
X    (setq hi
X      (pcmail-read-string-default
X        "Last message in range: "
X        (if (nth 1 pcmail-last-numeric-range)
X        (int-to-string (nth 1 pcmail-last-numeric-range))
X          (int-to-string lo))
X        t))
X    (cond ((string= hi "last")
X       (setq hi pcmail-total-messages))
X      ((or (not (setq hi (string-to-int hi)))
X           (< hi 1)
X           (> hi pcmail-total-messages))
X       (error "Range endpoint not 1 - %d or \"last\"."
X          pcmail-total-messages)))
X    (list (min lo hi) (max lo hi))))
X
X(provide 'pcmailsub)
________This_Is_The_END________
if test `wc -c < pcmailsub.el` -ne 17622; then
    echo 'shar: pcmailsub.el was damaged during transit (should have been 17622 bytes)'
fi
fi        ; : end of overwriting check
echo 'x - pcmailsysdep.el'
if test -f pcmailsysdep.el; then echo 'shar: not overwriting pcmailsysdep.el'; else
sed 's/^X//' << '________This_Is_The_END________' > pcmailsysdep.el
X;;;; GNU-EMACS PCMAIL mail reader
X
X;;  Written by Mark L. Lambert
X;;  Architecture Group, Network Products Division
X;;  Oracle Corporation
X;;  20 Davis Dr,
X;;  Belmont CA, 94002
X;;
X;;  internet: [e-mail] or [e-mail]
X;;  UUCP:     {hplabs,uunet,apple}!oracle!markl
X
X;; Copyright (C) 1989 Mark L. Lambert
X
X;; This file is not officially part of GNU Emacs, but is being
X;; donated to the Free Software Foundation.  As such, it is
X;; subject to the standard GNU-Emacs General Public License,
X;; referred to below.
X
X;; GNU Emacs is distributed in the hope that it will be useful,
X;; but WITHOUT ANY WARRANTY.  No author or distributor
X;; accepts responsibility to anyone for the consequences of using it
X;; or for whether it serves any particular purpose or works at all,
X;; unless he says so in writing.  Refer to the GNU Emacs General Public
X;; License for full details.
X
X;; Everyone is granted permission to copy, modify and redistribute
X;; GNU Emacs, but only under the conditions described in the
X;; GNU Emacs General Public License.   A copy of this license is
X;; supposed to have been given to you along with GNU Emacs so you
X;; can know your rights and responsibilities.  It should be in a
X;; file named COPYING.  Among other things, the copyright notice
X;; and this notice must be preserved on all copies.
X
X;;;; system-dependent things
X
X;;; mail environment.  For new environments, simply add a system-type switch
X;;; to the cond and put whatever properties you desire into the cond clause
X;;; examples for VMS and UNIX follow.  Currently all UNIXes are treated the
X;;; same.  This can change as required.  A fair amount of this code is
X;;; VMS-specific.  If you need to save space and you don't use VMS,
X;;; cut where indicated and throw the remainder of the file away.
X
X(cond ((eq system-type 'vax-vms)
X
X       ;; VMS system mail drop
X
X       (put 'vms-default-mail-drop 'conversion-function
X        'pcmail-convert-vms-message)
X       (put 'vms-default-mail-drop 'msg-start-regexp "^\^L\nFrom:[ \t]+")
X       (put 'vms-default-mail-drop 'insert-function 'pcmail-do-vms-movemail)
X
X       ;; VMS file mail drop, used to perform an initial import (extract
X       ;; your messages into a file and use this mail drop to import the
X       ;; file
X
X       (put 'vms-file-mail-drop 'conversion-function
X        'pcmail-convert-vms-message)
X       (put 'vms-file-mail-drop 'msg-start-regexp "^\^L\nFrom:[ \t]+")
X       (put 'vms-file-mail-drop 'insert-function 'pcmail-rename-mail-drop)
X       (put 'vms-file-mail-drop 'name-input-func
X        '(lambda () (pcmail-narrow-read-file-name "maildrop.log")))
X
X       ;; other environment stuff
X
X       (put 'pcmail-mail-environment 'printer "SYS$PRINT")
X       (put 'pcmail-mail-environment 'print-function 'pcmail-vms-print-message)
X       (put 'pcmail-mail-environment 'mail-directory
X        (concat (substring (getenv "HOME") 0 -1) ".pcmail]"))
X       (put 'pcmail-mail-environment 'time-zone "PST")
X       (put 'pcmail-mail-environment 'legal-folder-regexp
X        "[0-9A-Za-z][0-9A-Za-z---_$+.]+")
X       (put 'pcmail-mail-environment 'send-mail-function 'pcmail-vms-send-mail)
X       (put 'pcmail-mail-environment 'create-mail-directory-fn
X        'pcmail-vms-create-mail-directory)
X       (put 'pcmail-mail-environment 'folder-to-file-function
X        'pcmail-vms-folder-name-to-file)
X       (put 'pcmail-mail-environment 'default-mail-drop-list
X        '(vms-default-mail-drop)))
X
X      ;;; UNIX systems
X
X      (t
X
X       ;; NNTP mail drop
X
X       (put 'nntp-mail-drop 'conversion-function 'pcmail-convert-nntp-message)
X       (put 'nntp-mail-drop 'msg-start-regexp
X        "^\^L\n\\(Path\\|From\\|Xref\\):")
X       (put 'nntp-mail-drop 'insert-function 'pcmail-load-nntp-mail)
X       (put 'nntp-mail-drop 'display-errors-p t)
X       (put 'nntp-mail-drop 'folder-delete-hook 'pcmail-delete-nntp-folder)
X
X       ;; NNTP file mail drop -- this is a file of NNTP messages that have been
X       ;; assembled by the nntp-slave program.  An indirect variant of the
X       ;; above
X
X       (put 'nntp-file-mail-drop 'conversion-function
X        'pcmail-convert-nntp-message)
X       (put 'nntp-file-mail-drop 'msg-start-regexp "^\^L\n\\(Path\\|From\\):")
X       (put 'nntp-file-mail-drop 'insert-function 'pcmail-rename-mail-drop)
X       (put 'nntp-file-mail-drop 'folder-delete-hook
X        'pcmail-delete-nntp-folder)
X       (put 'nntp-file-mail-drop 'name-input-func
X        '(lambda () (pcmail-narrow-read-file-name "mail-log")))
X
X       ;; Berkeley-mail mail drops
X       (put 'spool-mail-drop 'conversion-function 'pcmail-convert-unix-message)
X       (put 'spool-mail-drop 'insert-function 'pcmail-do-unix-movemail)
X       (put 'spool-mail-drop 'msg-start-regexp "^From ")
X
X       (put 'berkeley-mail-drop 'conversion-function
X        'pcmail-convert-unix-message)
X       (put 'berkeley-mail-drop 'msg-start-regexp "^From ")
X       (put 'berkeley-mail-drop 'insert-function 'pcmail-rename-mail-drop)
X       (put 'berkeley-mail-drop 'name-input-func
X        '(lambda () (pcmail-narrow-read-file-name "~/mbox")))
X
X       ;; MH "mail drop"
X
X       (put 'mh-mail-drop 'conversion-function 'pcmail-convert-mh-message)
X       (put 'mh-mail-drop 'msg-start-regexp "^\^Lbegin-message\^L\n")
X       (put 'mh-mail-drop 'insert-function 'pcmail-do-mh-movemail)
X       (put 'mh-mail-drop 'display-errors-p t)
X
X       ;; other environment stuff
X
X       (put 'pcmail-mail-environment 'time-zone "PST")
X       (put 'pcmail-mail-environment 'legal-folder-regexp
X        "[0-9A-Za-z---_$.+%#&!]+")
X       (put 'pcmail-mail-environment 'printer (or (getenv "PRINTER") "lp"))
X       (put 'pcmail-mail-environment 'print-function 'pcmail-unix-lpr-message)
X       (put 'pcmail-mail-environment 'mail-directory "~/.pcmail/")
X       (put 'pcmail-mail-environment 'create-mail-directory-fn
X        'pcmail-unix-create-mail-directory)
X       (put 'pcmail-mail-environment 'folder-to-file-function 'identity)
X       (put 'pcmail-mail-environment 'default-mail-drop-list
X        '(spool-mail-drop))))
X
X;;;; UNIX functions
X
X;;; message print function
X
X(defun pcmail-unix-lpr-message (printer-name folder-name)
X  "Send current message to printer
XArgs: (printer-name folder-name)
X  Send the current message to the printer using LPR.  Call-process-region
Xon the current region.  Add job/title arguments so burst page looks nice."
X  (call-process-region (point-min) (point-max) "lpr"
X               nil nil nil
X               (concat "-P" printer-name)
X               (format "-J\"Msg %s/%d\"" folder-name
X                   (pcmail-make-absolute
X                pcmail-current-subset-message))
X               (format "-T\"Msg %s/%d\"" folder-name
X                   (pcmail-make-absolute
X                pcmail-current-subset-message))))
X
X;;; maildrop to folder move routines
X
X;; UNIX mail-drop transfer routine
X
X(defun pcmail-do-unix-movemail (mail-drop)
X  "UNIX mail-drop transfer function.
XArgs: (mail-drop)
XCall the emacs movemail utility to transfer <spool-directory>/foo to a
Xtemporary file, returning the temporary file's name to the caller.  If
XMAIL-DROP has a 'display-errors-p property, signal any errors from movemail
Xby formatting the movemail output in process output buffer."
X  (let ((fromfile (substitute-in-file-name
X           (concat (if (boundp 'rmail-spool-directory)
X                   rmail-spool-directory
X                 "/usr/spool/mail/")
X                 "$USER")))
X    (errors (get mail-drop 'display-errors-p))
X    (tofile (expand-file-name "~/.newmail")))
X
X    ;; On some systems, <spool-directory>/foo is a directory
X    ;; and the actual mail drop is <spool-directory>/foo/foo.
X    (and (file-directory-p fromfile)
X     (setq fromfile
X           (substitute-in-file-name (expand-file-name "$USER" fromfile))))
X    (cond ((file-exists-p fromfile)
X       (pcmail-generic-unix-movemail "movemail" exec-directory errors
X                     fromfile tofile)
X       tofile))))
X
X;; UNIX NNTP mail transfer routine
X
X(defun pcmail-load-nntp-mail (mail-drop)
X  "UNIX NNTP mail-drop transfer function.
XArgs: (mail-drop)
XCall the nntp_slave program to transfer netnews messages from a newgroup
Xwith the same name as the current folder to a temporary file. If MAIL-DROP
Xhas a 'display-errors-p property, signal any errors from movemail by
Xformatting the movemail output in process output buffer."
X  (let ((errors (get mail-drop 'display-errors-p))
X    (tofile (expand-file-name (concat pcmail-folder-name ".newnews")))
X    (controlfile (concat pcmail-folder-name ".ctl")))
X    (pcmail-generic-unix-movemail "nntp_slave" exec-directory errors
X                  pcmail-nntp-host-name pcmail-folder-name
X                  tofile controlfile)
X    tofile))
X
X(defun pcmail-delete-nntp-folder (folder-name)
X  "NNTP-mail-drop-specific folder delete processing
XArgs: (foler_name)
X  Run on delete of FOLDER_NAME with an attached nntp mail drop.  Deletes the
Xnntp_slave news control file associated with FOLDER_NAME."
X  (condition-case nil
X      (delete-file (expand-file-name (concat folder-name ".ctl")
X                     pcmail-directory))
X    (file-error nil)))
X
X;; Unix MH load
X
X(defun pcmail-do-mh-movemail (mail-drop)
X  "UNIX MH mail-drop transfer function.
XArgs: (mail-drop)
X  Read an MH folder name from the minibuffer and use an export utility to
Xmove all messages in the MH folder into a temporary file, returning
Xthe temporary file's name to the caller.  If MAIL-DROP has a
X'display-errors-p property, signal any errors from the shell script by
Xformatting the shell script output in the process output buffer."
X  (let* ((folder (pcmail-mh-read-folder-name))
X     (errors (get mail-drop 'display-errors-p))
X     (tofile (expand-file-name (concat "~/Mail/" folder "/" folder
X                       ".mhexport"))))
X    (pcmail-generic-unix-movemail "mh-to-pcmail-export" exec-directory
X                  errors folder tofile)
X    tofile))
X
X(defun pcmail-mh-read-folder-name ()
X  "Read a folder name from the minibuffer, using completion.
XArgs: none
X  Use pcmail-completing-read to read an MH folder name from the minibuffer.
XCompletion directory is the standard MH mail directory ~/Mail/.
XPcmail-completing-read takes an alist, so we need to convert the output of
Xfile-name-all-completions to alist form.  In the process, remove trailing
Xslashes from any directory names in the completion set.  Completion set
Xis filtered through a lambda expression that passes only directories and
Xeliminates the special directories \".\" and \"..\"."
X  (let ((mhdir (expand-file-name "~/Mail/")))
X    (or (file-directory-p mhdir)
X    (error "Default MH mail directory \"%s\" does not exist." mhdir))
X    (pcmail-completing-read
X     "Folder name: "
X     (mapcar '(lambda (s) (list (if (string-match ".*/$" s)
X                    (substring s 0 -1)
X                  s)))
X         (file-name-all-completions "" mhdir))
X     nil
X     '(lambda (s) (and (file-directory-p (expand-file-name (car s) mhdir))
X               (not (string= (car s) ".."))
X               (not (string= (car s) ".")))))))
X
X
X;; generic call-process and error-handling part of the above three routines
X
X(defun pcmail-generic-unix-movemail (progname dir errorbuf &rest args)
X  "Generic mail mover.  Calls a program, formatting and signalling errors.
XArgs: (progname dir tofile fromfile errorbuf &rest args)
X  If ERRORBUF is non-nil, generate an error buffer.  Call PROGNAME in
Xdirectory DIR, passing it arguments ARGS, and routing output to ERRORBUF
Xif present.  If errors occur, format the output in ERRORBUF and use it as
Xan argument to a file-error signal."
X  (and errors
X       (setq errors (generate-new-buffer (concat " *" progname " lossage*"))))
X  (unwind-protect
X      (save-excursion
X    (and errors (buffer-flush-undo errors))
X    (apply 'call-process (expand-file-name progname dir) nil errors nil
X           args)
X    (cond ((and errors (buffer-modified-p errors))
X           (set-buffer errors)
X           (subst-char-in-region (point-min) (point-max) ?\n ?\  )
X           (goto-char (point-max))
X           (skip-chars-backward " \t")
X           (delete-region (point) (point-max))
X           (goto-char (point-min))
X           (and (looking-at (concat progname ": "))
X            (delete-region (point-min) (match-end 0)))
X           (signal 'file-error
X               (list progname
X                 (buffer-substring (point-min) (point-max)))))))
X    (and errors (kill-buffer errors))))
X
X;;; Generic mail drop insert function
X
X(defun pcmail-rename-mail-drop (mail-drop)
X  "A generic mail drop insert function
XArgs: (mail-drop)
X  Read a source mail drop name from the minibuffer and rename it to a
Xtemporary file, returning the name of the temporary file to the caller."
X  (or (get mail-drop 'name-input-func)
X      (error "Missing mail drop name input property in mail drop %s"
X         mail-drop))
X  (let ((tofile)
X    (fromfile (funcall (get mail-drop 'name-input-func))))
X    (cond ((file-exists-p fromfile)
X       (setq tofile
X         (concat (file-name-directory fromfile) "new-"
X             (file-name-nondirectory fromfile)))
X       (rename-file fromfile tofile nil)
X       tofile))))
X
X;;; message conversion routines.  These functions look from point
X;;; forward for a message-begin regexp (end of current message, beginning of
X;;; next message).  They narrow to that region and reformat the message,
X;;; putting it in Babyl format and converting any non-conformant headers
X
X;;; default conversion routine
X
X(defun pcmail-convert-unknown-message ()
X  "Convert a message of unknown type to Babyl format.
X  Args: none
XThis routine is called when there is no match for a mail drop message-begin
Xregular expression.  Assumes the buffer is narrowed from point to end of
Xbuffer."
X    (insert pcmail-babyl-header)
X    (pcmail-add-babyl-attr nil "badheader")
X    (insert "Date: " (pcmail-todays-date) "\n")
X    (insert "From: \"The Mail Reader\" <pcmail>\n")
X    (insert "To: " pcmail-primary-folder-name "\n")
X    (insert "Subject: Could not convert this message to Babyl format")
X    (insert pcmail-header-delim)
X    (goto-char (point-min))
X    (while (search-forward pcmail-babyl-end nil t)
X      (replace-match (concat "\n" pcmail-babyl-exploded-end)))
X    (goto-char (point-max))
X    (insert pcmail-babyl-end))
X
X;;; Babyl conversion routine
X
X(defun pcmail-convert-babyl-message ()
X  "Convert a Babyl message to Babyl format
XArgs: (none)
X  Convert a Babyl message to Babyl format.  If looking at Babyl header, nuke
Xit.  If looking at Babyl message, remove summary-line field if present.
XAssume the current buffer is narrowed from point to end-of-buffer."
X  (cond ((looking-at "BABYL OPTIONS:")
X     (setq newmsgs (1- newmsgs)) ;not a real message
X     (re-search-forward pcmail-babyl-end nil 'move)
X     (delete-region (point-min) (point)))
X    ((looking-at pcmail-babyl-begin)
X     (let ((end) (case-fold-search t))
X       (cond ((re-search-forward pcmail-babyl-end nil 'move)
X          (delete-region (point)
X                 (progn (skip-chars-forward " \t\n")
X                    (point))))
X         (t
X          (insert pcmail-babyl-end)))
X       (save-excursion
X         (goto-char (point-min))
X         (cond ((search-forward pcmail-header-delim nil t)
X            (setq end (point))
X            (goto-char (point-min))
X            (and (re-search-forward
X              "^summary-line:.*\n\\([ \t]+.*\n\\)*" end t)
X             (replace-match "")))))))))
X
X;;; MH-export conversion routine
X
X(defun pcmail-convert-mh-message ()
X  "Convert an exported MH message to Babyl format.
XArgs: none
X  See pcmail-convert-unix-message."
X  (let ((start (point))
X    (msgseparator (get 'mh-mail-drop 'msg-start-regexp)))
X    ;point must be at this regexp; see convert-region-to-babyl-format
X    (re-search-forward msgseparator nil t)
X    (replace-match "")
X    (insert pcmail-babyl-header)
X    (cond ((re-search-forward (concat "\\(" msgseparator "\\)") nil t)
X       (goto-char (match-beginning 1)))
X      (t
X       (goto-char (point-max))))
X    (narrow-to-region start (point))
X    (goto-char (point-min))
X    (pcmail-bash-unix-header)
X    (goto-char (point-min))
X    (while (search-forward pcmail-babyl-end nil t)
X      (replace-match (concat "\n" pcmail-babyl-exploded-end)))
X    (goto-char (point-max))
X    (widen)
X    (insert pcmail-babyl-end)))
X
X;;; Berkeley MAIL conversion routine
X
X(defun pcmail-convert-unix-message ()
X  "Convert a Berkeley Mail message to Babyl format.
XArgs: none
X  Convert a UNIX-style Mail message to Babyl format.  Regexps snarfed from
XRMAIL.  Assumes the current buffer is narrowed from point to end of buffer."
X  (let ((start (point)))
X    (insert pcmail-babyl-header)
X    (forward-line 1)                   ;over first line
X    (if (re-search-forward               ; UNIX header regexp...
X     (concat "^\\("
X         "From [^ \n]*\\(\\|\".*\"[^ \n]*\\)  ?[^ \n]* [^ \n]* *"
X         "[0-9]* [0-9:]* "           ; time of day
X         "\\([A-Z]?[A-Z][A-Z]T \\|"        ; 3-char time zone
X         "[-+][0-9][0-9][0-9][0-9] \\|\\)" ; numeric offset time zone
X         "19[0-9]*$\\)") nil t)
X    (goto-char (match-beginning 1))
X      (goto-char (point-max)))
X    (narrow-to-region start (point))
X    (goto-char (point-min))
X    (pcmail-bash-unix-header)
X    (goto-char (point-min))
X    (while (search-forward pcmail-babyl-end nil t)
X      (replace-match (concat "\n" pcmail-babyl-exploded-end)))
X    (goto-char (point-max))
X    (widen)
X    (insert pcmail-babyl-end)))
X
X(defun pcmail-bash-unix-header ()
X  "Turn a Berkeley Mail header into an RFC822 header
XArgs: none"
X  (let ((hdrend (progn
X          (or (re-search-forward pcmail-header-delim nil 'move)
X              (insert pcmail-header-delim))
X          (point)))
X    (case-fold-search t))
X    (save-excursion
X      (save-restriction
X    (narrow-to-region (point-min) hdrend)
X    (goto-char (point-min))
X    (pcmail-maybe-gronk-unix-header)))))
X
X(defun pcmail-maybe-gronk-unix-header ()
X  "Transform unix mail header.
XArgs: none
X  If there is a righteous from or date field, nuke the non-standard Berkeley
Xfrom field, otherwise extract from and date field info from it and create
Xrighteous fields before nuking the Berkeley from field.  Assume buffer is
Xnarrowed to the message header."
X  (let ((case-fold-search t) (has-from) (has-date))
X    (goto-char (point-min))
X    (and (re-search-forward "^Date:[ \t]+.*\n\\([\t ]+.*\n\\)*" nil t)
X     (setq has-date t))
X    (goto-char (point-min))
X    (and (re-search-forward "^From:[ \t]+.*\n\\([\t ]+.*\n\\)*" nil t)
X     (setq has-from t))
X    (goto-char (point-min))
X
X    ; if the header has neither a from nor a date field, create them using
X    ; the Berkeley from field
X    (let ((case-fold-search nil))
X      (and (re-search-forward    ;The Pinhead Header
X        "^From \\([^ ]*\\(\\|\".*\"[^ ]*\\)\\)  ?\\([^ ]*\\) \\([^ ]*\\) *\\([0-9]*\\) \\([0-9:]*\\)\\( [A-Z]?[A-Z][A-Z]T\\|[-+][0-9][0-9][0-9][0-9]\\|\\) 19\\([0-9]*\\)\n" nil t)
X       (replace-match
X        (concat
X         (cond (has-date
X            "")
X           ((= (match-beginning 7) (match-end 7))
X            (concat "Date: \\3, \\5 \\4 \\8 \\6 " pcmail-time-zone
X                "\n"))
X           (t
X            "Date: \\3, \\5 \\4 \\8 \\6\\7\n"))
X         (cond (has-from
X            "")
X           (t
X            "From: \\1\n"))))))))
X
X;;; NNTP message conversion routine
X
X(defun pcmail-convert-nntp-message ()
X  "Convert an NNTP slave message to Babyl format.
XArgs: none
X  See pcmail-convert-unix-message."
X  (let ((start (point)))
X    ;point must be at this regexp; see convert-region-to-babyl-format
X    (re-search-forward "^\^L\n" nil t)
X    (replace-match pcmail-babyl-header)
X    (cond ((re-search-forward "\\(^\^L\n\\)\\(Path\\|From\\|Xref\\):[ \t]+"
X                  nil t)
X       (goto-char (match-beginning 1)))
X      (t
X       (goto-char (point-max))))
X    (narrow-to-region start (point))
X    (goto-char (point-min))
X    (pcmail-bash-nntp-header)
X    (goto-char (point-min))
X    (while (search-forward pcmail-babyl-end nil t)
X      (replace-match (concat "\n" pcmail-babyl-exploded-end)))
X    (goto-char (point-max))
X    (widen)
X    (insert pcmail-babyl-end)))
X
X(defun pcmail-bash-nntp-header ()
X  "Turn an NNTP message into a mail message.
XArgs: none
XSimple routine to change the NNTP Newsgroups: field into a To: field so
Xthat the mail reader will be happy (mail messages need To: fields)."
X  (let ((hdrend (progn
X          (or (re-search-forward pcmail-header-delim nil 'move)
X              (insert pcmail-header-delim))
X          (point)))
X    (case-fold-search t))
X    (save-excursion
X      (save-restriction
X    (narrow-to-region (point-min) hdrend)
X    (and (re-search-backward "^Newsgroups:" nil t)
X         (replace-match "To:"))))))
X
X
X;;; initial mail directory create
X
X(defun pcmail-unix-create-mail-directory ()
X  "Create UNIX local mail directory.
XArgs: none"
X  (call-process "mkdir" nil nil nil
X        (directory-file-name (expand-file-name pcmail-directory))))
X
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;;;;
X;;;; VMS SYSTEM-SPECIFIC FUNCTIONS.  IF YOU DON'T RUN VMS AND WANT TO SAVE
X;;;; SPACE, CUT HERE, BEGING CAREFUL TO PRESERVE THE (PROVIDE 'PCMAILSYSDEP)
X;;;; FORM ON THE LAST LINE OF THE FILE
X;;;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X;;; message print function
X
X(defun pcmail-vms-print-message (printer-name &ignore)
X  "Send the current message to printer queue.
XArgs: (printer-name &ignore)
X  Send the current message to printer queue PRINTER-NAME using a canned
XCOM file.  First write message to a file.  COM file prints the file and may
Xdelete it."
X  (let ((temp-file (expand-file-name "pcmail-msg.txt" pcmail-directory))
X    (com-file (expand-file-name "vms-doprint.com" exec-directory))
X    (bname (buffer-name)))
X    (write-region (point-min) (point-max) temp-file)
X    (pcmail-vms-command (format "@%s %s %s" com-file printer-name
X                temp-file "delete"))
X    (set-buffer bname)))        ;pcmail-vms-command lossage
X
X;;; directory create function
X
X(defun pcmail-vms-create-mail-directory ()
X  "Create VMS local mail directory.
XArgs: none"
X  (pcmail-vms-command (concat "create/dir " pcmail-directory))
X  (while (not (file-directory-p pcmail-directory))))
X
X
X;;; mail-drop move function
X
X(defun pcmail-do-vms-movemail (mail-drop)
X  "VMS mail-drop transfer function.
XArgs: (mail-drop)
X  Call a COM file to transfer a file named newmail into a temporary file
Xnamed newmail.  Return the file name to the caller.  Assumes existence of
Xa function called pcmail-vms-command which does a non-blocking exexute of a
XDCL command in an kept inferior process."
X  (let ((bname (buffer-name))
X    (fromfile "newmail")
X    (tofile "mail.temp"))
X    (condition-case nil
X    (delete-file tofile)        ;in case of previous lossage
X      (file-error nil))
X    (pcmail-vms-command (concat "@"
X             (expand-file-name "vms-movemail.com" exec-directory)
X             " "
X             fromfile
X             " "
X             tofile
X             " "
X             (file-name-directory (buffer-file-name))))
X    (set-buffer bname)                        ;pcmail-vms-command lossage
X    (while (not (file-exists-p tofile)))         ;gag, choke, nonblocking call
X    tofile))
X
X
X;;; convert a VMS VAX-MAIL message to a Babyl message.  This is pretty
X;;; horrific, but works well enough.
X
X(defun pcmail-convert-vms-message ()
X  "Convert a VMS-style message to Babyl format.
XArgs: none
X  See pcmail-convert-unix-message."
X  (let ((start (point))
X    (msg-start-regexp "^\^L\nFrom:[ \t]+"))
X    ;point must be at this regexp; see convert-region-to-babyl-format
X    (re-search-forward "^\^L\n" nil t)
X    (replace-match pcmail-babyl-header)
X    (cond ((re-search-forward
X        (concat "\\(^\^L\n\\)From:[ \t]+.+[0-9]+-[a-zA-Z]+-"
X            "19[0-9]+[ \t]*[0-9]+:[0-9]+")
X        nil t)
X       (goto-char (match-beginning 1)))
X      (t
X       (goto-char (point-max))))
X    (narrow-to-region start (point))
X    (goto-char (point-min))
X    (pcmail-bash-vms-header)
X    (goto-char (point-min))
X    (while (search-forward pcmail-babyl-end nil t)
X      (replace-match (concat "\n" pcmail-babyl-exploded-end)))
X    (goto-char (point-max))
X    (widen)
X    (insert pcmail-babyl-end)))
X
X(defun pcmail-bash-vms-header ()
X  "Convert a VMS message header to at least minimally resemble an RFC822 header
XArgs: none
X  Assume the region is narrowed to the current message."
X  (let ((hdrend (progn
X          (or (re-search-forward pcmail-header-delim nil 'move)
X              (insert pcmail-header-delim))
X          (point)))
X    (case-fold-search t))
X    (save-excursion
X      (save-restriction
X    (narrow-to-region (point-min) hdrend)
X    (pcmail-maybe-gronk-vms-header)))))
X
X(defun pcmail-maybe-gronk-vms-header ()
X  "Reformat or nuke VMS fields as necessary.  Not too bad.
XArgs: none"
X  (goto-char (point-min))
X  (cond ((re-search-forward
X      (concat "^From:\t"            ;Anatomy of a VMS From: field
X          "\\(\\(\\w+::\\)?"            ;optional host name
X          "\\(\\w+\\)"                    ;user name
X          "[ \t]*\\(\".*\"\\)?[ \t]*\\)";comment
X          "\\([0-9]+\\)-"         ;day
X          "\\([a-zA-Z]+\\)-"        ;month
X          "19\\([0-9]+\\)[ \t]*"    ;year
X          "\\([0-9]+:[0-9]+\\)\\(:[0-9]+\\)?.*\n")      ;time
X      nil t)
X     (replace-match
X      (concat "Date: \\5 "
X          (capitalize
X           (buffer-substring (match-beginning 6) (match-end 6)))
X          " \\7 \\8 " pcmail-time-zone "\n"
X          "From: \\1\n")
X      t)))
X
X  ; find subject and reformat if it exists, punt if blank
X  (goto-char (point-min))
X  (let ((no-subject) (has-cc) (has-to))
X    (setq no-subject
X      (let ((temp-subj (mail-fetch-field "subj")))
X        (zerop (length temp-subj))))
X    (and (re-search-forward "^Subj:\t\\(.*\n\\([ \t]+.*\n\\)?\\)" nil t)
X     (replace-match (if no-subject "" "Subject: \\1") t))
X
X    ; find CC and reformat if it exists, punt if blank
X    (goto-char (point-min))
X    (setq no-cc
X      (let ((temp-cc (mail-fetch-field "cc")))
X        (zerop (length temp-cc))))
X    (and (re-search-forward "^CC:\t\\(.*\n\\([ \t]+.*\n\\)?\\)" nil t)
X     (if no-cc
X         (replace-match "")
X       (replace-match "Cc: \\1" t)))
X
X    ; find to: field and reformat if no other to fields exists
X    (goto-char (point-min))
X    (and (re-search-forward "^To:\t" nil t)
X     (replace-match "To: "))))
X
X;;; folder-to-file translate function
X
X(defun pcmail-vms-folder-name-to-file (folder-name)
X  "Return a copy of FOLDER-NAME that has been translated into a valid VMS
Xfile name.  The translation converts \".\" characters into \"_\" characters
Xand \"+\" characters into \"$\" characters."
X  (let ((i 0) (outbox (copy-sequence folder-name)))
X    (while (< i (length outbox))
X      (and (= (aref outbox i) ?.) (aset outbox i ?_))
X      (and (= (aref outbox i) ?+) (aset outbox i ?$))
X      (setq i (1+ i)))
X    outbox))
X
X;;; mail transmission function
X
X(defconst pcmail-vms-mailcopy "SYS$SCRATCH:MAIL.CPY"
X  "File used to store body of message when using VMS mail utility.
XDeleted on mail transmit.")
X
X(defun pcmail-vms-send-mail ()
X  "Send a message using VMS Mail.
XArgs: none
X  Copy message body to a file.  Using message header, create TO and SUBJECT
Xarguments after converting addresses from RFC822 format to VMS format.
XCall VMS MAIL with to, subject, and body file arguments.  Note that this is
Xa hack, and may break down from time to time."
X  (let ((tembuf) (case-fold-search t) (to) (cc) (subj) (delimline)
X    (mailbuf (current-buffer)))
X    (and (file-exists-p pcmail-vms-mailcopy) (delete-file pcmail-vms-mailcopy))
X    (find-file pcmail-vms-mailcopy)
X    (unwind-protect
X    (save-excursion
X      (save-restriction
X        (setq tembuf (current-buffer))
X        (erase-buffer)
X        (insert-buffer-substring mailbuf)
X        ;; Find end of header and narrow to it.
X        (goto-char (point-min))
X        (or (re-search-forward
X         (concat "^" (regexp-quote mail-header-separator)))
X        (error "Improperly formatted mail buffer."))
X        (setq delimline (point-marker))
X        (replace-match "")
X        (narrow-to-region (point-min) delimline)
X
X        ;; Find and handle any aliases.
X        (and mail-aliases
X         (expand-mail-aliases (point-min) delimline))
X
X        ;; Remove any blank lines in the header.
X        (goto-char (point-min))
X        (while (re-search-forward "^[ \t\n]*\n" delimline t)
X          (replace-match ""))
X
X        ;; Find and handle any FCC fields.
X        (goto-char (point-min))
X        (and (re-search-forward "^FCC:" delimline t)
X         (mail-do-fcc delimline))
X
X        ;; don't send out a blank subject line
X        (goto-char (point-min))
X        (and (re-search-forward "^Subject:[ \t]*\n" delimline t)
X         (replace-match ""))
X
X        (goto-char (point-min))
X        (pcmail-vms-mail-convert-text-field "subject")
X        (setq to (or (mail-fetch-field "to" nil t)
X             (error "Message must have a to: recipient.")))
X        (setq cc (mail-fetch-field "cc" nil t))
X        (and cc (setq to (concat to "," cc)))
X        (setq to (pcmail-vms-mail-nl-to-space to))
X        (if (setq subj (mail-fetch-field "subject" t))
X        (setq subj (pcmail-vms-mail-nl-to-space
X                (concat "/SUBJECT=\"" subj "\"")))
X          (setq subj "")))
X      (delete-region (point-min) delimline)
X      (write-file (buffer-file-name))
X      ;; Make call to VMS Mail.
X      (pcmail-vms-command (concat "MAIL" subj " -"))
X      (pcmail-vms-command (concat pcmail-vms-mailcopy " -"))
X      (pcmail-vms-command (concat "\"" to "\""))
X      (pcmail-vms-command " "))    ; to clear out any prompts due to errors
X      (set-buffer tembuf)
X      (set-buffer-modified-p nil)
X      (kill-buffer tembuf))))
X
X(defun pcmail-vms-mail-convert-text-field (field)
X  "Convert RFC822 text fields to VMS format.
XArgs: (field)"
X  (let ((start)
X    (case-fold-search t))
X    (save-excursion
X      (save-restriction
X    (goto-char (point-min))
X    (cond ((re-search-forward (concat "^" (regexp-quote field) ":[ \t]*")
X                  nil t)
X           (setq start (point))
X           (while (progn (forward-line 1)
X                 (looking-at "[ \t]")))
X           (narrow-to-region start (point))
X           (goto-char start)
X           (while (re-search-forward "\"" nil t)
X         (replace-match "\"\""))))))))
X
X(defun pcmail-vms-mail-nl-to-space (s)
X  "Convert all whitespace in S to spaces and return the result.  Modifies S.
XArgs: (s)"
X  (let ((i 0))
X    (while (< i (length s))
X      (and (or (= (aref s i) ?\n)
X           (= (aref s i) ?\t))
X       (aset s i ? ))
X      (setq i (1+ i))))
X  s)
X
X
X;;; subprocess capability.  NOTE THAT THIS IS A HACK.  A GRUNGY HACK.
X
X(defvar pcmail-vms-process-id nil
X  "Process ID of inferior VMS process used by pcmail-vms-command.")
X
X(defvar pcmail-vms-process-buffer "*DCL Output*"
X  "Name of buffer where output from VMS process goes.")
X
X(defun pcmail-vms-command (s)
X  "Send a string S to a kept inferior VMS process.
XArgs: (s)
X  If variable PCMAIL-VMS-PROCESS-ID is unbound, spawn a process using the
XSPAWN-PROCESS function.  Then send S to the process using the
XSEND-COMMAND-TO-SUBPROCESS function."
X  (cond ((not pcmail-vms-process-id)
X     (setq pcmail-vms-process-id (random))
X     (spawn-subprocess pcmail-vms-process-id 'pcmail-vms-process-input)))
X  (send-command-to-subprocess pcmail-vms-process-id s))
X
X(defun pcmail-vms-process-input (id s)
X  "Called when input string S arrives from VMS process with handle ID
XArgs: (id s)
X  Place input in buffer PCMAIL-VMS-PROCESS-BUFFER and display that buffer in
Xanother window."
X  (pop-to-buffer pcmail-vms-process-buffer)
X  (goto-char (point-max))
X  (insert s))
X
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X;;;;
X;;;; STOP CUTTING HERE
X;;;;
X;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
X
X(provide 'pcmailsysdep)
________This_Is_The_END________
if test `wc -c < pcmailsysdep.el` -ne 30775; then
    echo 'shar: pcmailsysdep.el was damaged during transit (should have been 30775 bytes)'
fi
fi        ; : end of overwriting check
exit 0