Re: How to change from address while in message buffer?

[Helmut Waitzmann <nn.throttle@xoxy.net>]

Pankaj Jangid <p4j@j4d.net>:
>Malcolm Purvis <malcolm@purvis.id.au> writes:

>> If you split your mail from different addresses into different
>> groups (say home and work), then you can configure the variable
>> gnus-posting-styles to set the default From address for each
>> group, as well as signatures, outgoing SMTP server, etc.
>
>Yes. This works fine. I am using this.

So do I.

>My only problem is when I am already in *unsent message* buffer
>and want to change "From:" header value.
>

Yes, that was my problem, too.

I wrote a set of lisp functions and variables, that, when it comes
to send a message, look in the unsent message buffer for to
investigate which mail sending service – may it be SMTP or
sendmail – should be used and what parameters should be set.

They send mail via smtpmail or sendmail, depending on the message
header:

In the message buffer, the "X-My-MSA-Account" header field is
looked up, if present, else the "Sender" header field, if present,
else the "From" header field.  The e-mail-address in that header
field is extracted and used to determine the message submission
accounts for looking up the message submission configuration (see
variable my-messagesubmission-configuration) by using regular
expressions matching on the extracted e-mail address.

That configuration is then modified by the contents of the
"X-My-MSA-Configuration" header field (if present).  (This allows
to even change the configuration ad hoc in the message buffer.) 
According to the configuration, smtpmail or sendmail variables are
set.  Then the message is sent via the smtpmail or sendmail
mailers.

To install that library, I put the functions and variables into
the file "~/emacslisp/messagesubmission.el" (see below) – you are
free to choose a different name –, then byte-compiled it.

To make use of the library, I 'load' it from my emacs startup file
and set the variables 'message-send-mail-function' and
'send-mail-function' to the appropriate functions:

;;;;
;;;; This is to be part of the emacs startup file:
;;;;

;; Load the message submission service file:
(load "~/emacslisp/messagesubmission")
;; Note: There is no ".el" file name extension by intention.

;; Have the library hooked in:

(setq-default
 message-send-mail-function
 (function my-messagesubmission-message-send-mail)
 send-mail-function
 (function my-messagesubmission-send-mail))

;; Configure the message submission variables:

(setq-default my-messagesubmission-debug nil)
;; Set it to 't' to have the configuration used when sending a message
;; logged in the "*Messages*" buffer.

(setq-default
 my-messagesubmission-configuration
 '(
   ;; If the originator address is someone at home, I'd like to use
   ;; sendmail:
   ;;
   (("@\\(?:[[:graph:]]+\\.\\)?at-home\\.example\\'" t)

    ;; Use sendmail for sending mail:
    ;;
    (send-mail-function sendmail-send-it)
    (message-send-mail-function message-send-mail-with-sendmail)

    ;; If sendmail-f is not evil, let the address to be used in the
    ;; MAIL FROM SMTP command be the address from which the message
    ;; pretends to originate.
    ;; Else compute the address by using the userid.
    ;;
    (message-sendmail-f-is-evil t))

   ;; I've got two mail accounts at the freemail provider
   ;; "freemail.example". This is the common part of its
   ;; configuration:
   ;;
   (("@freemail\\.example\\'" t)

    ;; Let gnus speak SMTP to the fremailer's SMTP server:
    ;;
    (send-mail-function smtpmail-send-it)
    (message-send-mail-function message-smtpmail-send-it)

    ;; This is the SMTP server:
    ;;
    (smtpmail-smtp-server "smtp.freemail.example")

    ;; Use STARTTLS:
    ;;
    (smtpmail-smtp-service 587)
    (clientcertfile nil)
    (clientkeyfile nil)
    (mail-specify-envelope-from t))

   ;; One of the two accounts at freemail.example:
   ;;
   (("\\`Helmut\\.Waitzmann@freemail\\.example\\'" t)
    (username "Helmut.Waitzmann")
    (password "secret")
    (mail-envelope-from "Helmut.Waitzmann@freemail.example"))

   ;; The other of the two accounts at freemail.example:
   ;;
   (("\\`Helmut\\.Waitzmann\\.nospam@freemail\\.example\\'" t)
    (username "Helmut.Waitzmann.nospam")
    (password "even more secret")
    (mail-envelope-from "Helmut.Waitzmann.nospam@freemail.example"))

   ;; At work, I'll use SMTP to submit a message:
   ;;
   (("\\`\\(waitzmann@at-work\\.example\\)\\'" t)
    (send-mail-function smtpmail-send-it)
    (message-send-mail-function message-smtpmail-send-it)
    (smtpmail-smtp-server "smtp.at-work.example")

    ;; STARTTLS
    ;;
    (smtpmail-smtp-service 25)
    (clientcertfile nil)
    (clientkeyfile nil)
    (username "waitzmann")

    ;; Ask me for the password:
    ;;
    (password nil)
    (mail-specify-envelope-from t)
    (mail-envelope-from "waitzmann@at-work.example"))))

(setq-default smtpmail-debug-info nil)
(setq-default smtpmail-debug-verb nil)

;;;;
;;;; This is the file "~/emacslisp/messagesubmission.el":
;;;;

(defconst my-messagesubmission-configuration-symbols
  (let ((configsymbols (make-vector 29 0)))
    (mapc
     (function
      (lambda (cons)
        (let
            ((symbol (my-car-strict cons))
             (predicate (my-cdr-strict cons))
             configsymbol)
          (unless (and symbol (symbolp symbol))
            ;; No non-nil symbol:
            (signal
             'wrong-type-argument
             (list
              (lambda (symbol) (and symbol (symbolp symbol)))
              symbol)))
          (unless (or (null predicate) (functionp predicate))
            (signal
             'wrong-type-argument
             (list
              (lambda (predicate)
                (or (null predicate) (functionp predicate)))
              predicate)))
          (setq configsymbol (intern (symbol-name symbol) configsymbols))
          (set configsymbol predicate))))
     (list
      ;; list of conses of each a configuration symbol and the predicate to be
      ;; satisfied.  Each list entry is a cons, the car of which is the
      ;; configuration symbol, and the cdr of which is
      ;; either nil: Then the configuration symbol shall be unbound.
      ;; or t: Then the configuration symbol may have a value of any kind.
      ;; or a predicate: Then the configuration symbol shall have a value
      ;;    that shall satisfy the predicate.
      (cons 'my-messagesubmission-debug 'booleanp)
      (cons 'smtpmail-debug-info (lambda (value) t))
      (cons 'smtpmail-debug-verb (lambda (value) t))
      (cons 'message-send-mail-function (lambda (value) t))
      (cons 'send-mail-function (lambda (value) t))
      (cons 'message-sendmail-f-is-evil (lambda (value) t))
      (cons 'message-sendmail-envelope-from
            (lambda (value) (or (null value) (eq value 'header))))
      (cons 'message-send-mail-partially-limit
            (lambda (value) (or (null value) (integerp value))))
      (cons 'message-interactive (lambda (value) t))
      (cons 'smtpmail-mail-address 'stringp)
      (cons 'smtpmail-smtp-server 'stringp)
      (cons
       'smtpmail-smtp-service
       (lambda (value) (or (stringp value) (integerp value))))
      (cons
       'smtpmail-auth-credentials
       (lambda (value)
	 (or
	  (stringp value)
	  (and (consp value)
	       (stringp (nth 0 value))
	       (integerp (nth 1 value))
	       (stringp (nth 2 value))
	       (let ((v (nth 3 value)))
		 (or (null v) (stringp v)))))))
      (cons
       'smtpmail-starttls-credentials
       (lambda (value)
	 (and (consp value)
	      (stringp (nth 0 value))
	      (integerp (nth 1 value))
	      (let ((v (nth 2 value)))
		(or (null v) (stringp v)))
	      (let ((v (nth 3 value)))
		(or (null v) (stringp v))))))
      (cons
       'username
       (lambda (value) (or (null value) (stringp value))))
      (cons
       'password
       (lambda (value) (or (null value) (stringp value))))
      (cons
       'clientkeyfile
       (lambda (value) (or (null value) (stringp value))))
      (cons
       'clientcertfile
       (lambda (value) (or (null value) (stringp value))))
      (cons 'starttls-use-gnutls 'booleanp)
      (cons 'starttls-gnutls-program 'stringp)
      (cons 'starttls-extra-arguments 'listp)
      (cons
       'smtpmail-local-domain
       (lambda (value) (or (null value) (stringp value))))
      (cons
       'smtpmail-sendto-domain
       (lambda (value) (or (null value) (stringp value))))
      (cons 'mail-specify-envelope-from 'booleanp)
      (cons 'mail-envelope-from (lambda (value) t))))
    configsymbols)
  "*obarray containing the symbols, the symbol-names of which denote
legal configuration variables which may be set in variable
my-messagesubmission-configuration.  Each symbol's symbol-value is
either nil: Then the configuration symbol shall be unbound.
or t: Then the configuration symbol may have a value of any kind.
or a predicate: Then the configuration symbol shall have a value
   that shall satisfy the predicate.")

(defvar my-messagesubmission-configuration
  nil
  "*List of message submission configurations parts.
Each element of this list is a (part of a) message submission
configuration.
Each message submission configuration part consists of
  * a regular expression matcher to match the message submission account of
    the message to be sent:  The regular expression matcher is
    * either a string. Then it is a case sensitive regular expression.
    * Or it is a list containing 2 elements:
      * 1st: a string: the regular expression to be matched
      * 2nd: a boolean: if non-nil, indicating, the matching should ignore
        case.
  * zero or more keyword assignments:  Each keyword assignment is a list:
    (keyword value).  The keywords, together with their value types are as
    follows:

    keyword                       | valuetype
    ------------------------------+----------------------------------------
    send-mail-function            | see variable send-mail-function
    message-send-mail-function    | see variable message-send-mail-function
    smtpmail-smtp-server          | string
    smtpmail-smtp-service         | integer or string, e.g. 587 or \"smtp\"
    username                      | string (or nil to be prompted for)
    password                      | string (or nil to be prompted for)
    clientkeyfile                 | string or nil (see below)
    clientcertfile                | string or nil (see below)

    Any variable that satisfies the predicate user-variable-p may be
    specified, too.  But be careful not to include user-variables of this
    package.

    smtpmail-smtp-server
      is the server to connect to.  Will be used to set the variable
      smtpmail-smtp-server.  Will also be used to set the variables
      smtpmail-auth-credentials and smtpmail-starttls-credentials.

    smtpmail-smtp-service
      is the port to connect to.  Will be used to set the variable
      smtpmail-smtp-service.  Will also be used to set the variables
      smtpmail-auth-credentials and smtpmail-starttls-credentials.

    username
      will be used to set the variable smtpmail-auth-credentials.

    password
      will be used to set the variable smtpmail-auth-credentials.

    clientkeyfile
      is the name of a file (maybe nil, if you do not wish to use client
      authentication), containing a client key.  Will be used to set the
      variable smtpmail-starttls-credentials.

    clientcertfile
      is the name of a file (maybe nil, if you do not wish to use client
      authentication), containing a client certificate.  Will be used to
      set the variable smtpmail-starttls-credentials.

    So each element might look like this example:
    \(
      (\"\\\\`me@domain\\\\.example\\\\'\" nil)
      (message-send-mail-function 'message-smtpmail-send-it)
      (send-mail-function 'smtpmail-send-it)
      (smtpmail-smtp-server \"mail.domain.example\")
      (smtpmail-smtp-service 587)
      (username \"me\") (password nil)
      (clientkeyfile \"keyfile\") (clientcertfile \"certfile\")
    )")

(defvar my-messagesubmission-debug nil
  "*If non-nil, prints the configuration via the function 'message'.")

(defun my-messagesubmission-send-mail nil
  "Send mail via variable send-mail-function.
This function simply calls
\(my-messagesubmission-send-mail-via 'send-mail-function)"
  (my-messagesubmission-send-mail-via 'send-mail-function))

(defun my-messagesubmission-message-send-mail nil
  "Send mail via variable message-send-mail-function.
This function simply calls
\(my-messagesubmission-send-mail-via 'message-send-mail-function)"
  (my-messagesubmission-send-mail-via 'message-send-mail-function))

(defun my-messagesubmission-send-mail-via (via)
  "Send mail via smtpmail or sendmail, depending on the message header.
In the message buffer, the \"X-My-MSA-Account\" header line is looked up,
if present, else the \"Sender\" header line, if present, else the \"From\"
header line.  The e-mail-address is extracted and used to determine the
message submission account for looking up the message submission
configuration (see variable my-messagesubmission-configuration).  That
configuration is modified by the contents of the \"X-My-MSA-Configuration\"
header line (if present).  According to the configuration, smtpmail or
sendmail variables are set.  Then the message is sent via the smtpmail or
sendmail mailers."
  (eval-when-compile (require 'smtpmail))
  (let*
      ((account (my-messagesubmission-account))
       (assignments (my-messagesubmission-X-My-MSA-Configuration))
       (newvars
        (my-messagesubmission-configuration-variables
         account
	 (append
	  my-messagesubmission-configuration
	  (list (cons '("" nil) assignments)))))
       (savedvars (make-vector (length newvars) 0)))
    ;; Store some symbols, which will be modified later, in newvars to have
    ;; them saved and restored (in case they aren't already there), too:
    (let ((symbols
           '(smtpmail-auth-credentials
             smtpmail-starttls-credentials
             message-send-mail-function
             send-mail-function)))
      (while symbols
        (intern (symbol-name (car symbols)) newvars)
        (setq symbols (cdr symbols))))
    ;; Save the current values:
    (my-utils-copy-symbol-values newvars obarray savedvars)
    (let
        (username
         password
         clientkeyfile
         clientcertfile)
      (let((symbols
            '(username password clientkeyfile clientcertfile)))
        (while symbols
          (makunbound (car symbols))
          (setq symbols (cdr symbols))))
      (unwind-protect
          (progn
            ;; Assign the new values:
            (my-utils-copy-symbol-values newvars newvars obarray)
	    (when (and (boundp 'smtpmail-smtp-server)
		       (boundp 'smtpmail-smtp-service))
	      (when (and (boundp 'username) (boundp 'password))
		(setq
		 smtpmail-auth-credentials
		 (list
		  (list smtpmail-smtp-server smtpmail-smtp-service
			username password))))
	      (when (and (boundp 'clientkeyfile) (boundp 'clientcertfile))
		(setq smtpmail-starttls-credentials
		      (list
		       (list smtpmail-smtp-server smtpmail-smtp-service
			     clientkeyfile clientcertfile)))))
	    (when my-messagesubmission-debug
	      (message
	       "\n%S(%S):\nmessagesubmission configuration for account\n%S:\n"
	       'my-messagesubmission-send-mail-via via account)
	      (mapc
	       (function
		(lambda (symbol)
		  (let ((var (intern-soft (symbol-name symbol))))
		    (when var
		      ;; There is a symbol var:
		      (if (boundp var)
			  ;; That symbol has got a symbol-value, i.e. it
			  ;; is a variable:
			  (message
			   " (setq %S '%S)" var (symbol-value var))
			;; That symbol has got no symbol-value:
			(message
			 " (makunbound '%S)" var))))))
	       (let (symbols)
		 (mapatoms
		  (function
		   (lambda (symbol)
		     (setq symbols (cons symbol symbols))))
		  newvars)
		 (sort
		  symbols
		  (function
		   (lambda (s1 s2)
		     (< (compare-strings
			 (symbol-name s1) 0 nil
			 (symbol-name s2) 0 nil)
			0)))))))
	    ;; Remove any "X-My-MSA-Account" and "X-My-MSA-Configuration"
	    ;; headers:
	    (let ((deactivate-mark deactivate-mark))
	      (save-excursion
		(save-restriction
		  (message-narrow-to-headers)
		  (message-remove-header
		   "^X-My-MSA-\\(?:Account\\|Configuration\\)[ \t]*:" t))))
            ;; Send the message:
            (funcall (symbol-value via)))
        ;; Restore the saved variables:
        (my-utils-copy-symbol-values newvars savedvars obarray)))))

(defun my-messagesubmission-configuration-variables (account configuration)
  "The assigned-to symbols from configuration.
The return value is an obarray containing the assigned-to symbols.
ACCOUNT (a string) is the name of the message submission account, the
entries of my-messagesubmission-configuration are matched with."
  (let
      ((assignments
        ;; the (keyword value) pairs in my-messagesubmission-configuration
        ;; matching the MSA-account
        (apply
         (function append)
         (mapcar
          (function
           (lambda (alistentry)
             (let ((regexpmatcher (car-safe alistentry))
                   regexp
                   case-fold-search)
               (if (consp regexpmatcher)
                   ;; then regexpmatcher should be a list consisting of 2
                   ;; elements:  The first element is a string, the regular
                   ;; expression.  The second element is a boolean value
                   ;; for case-fold-search: If it is not nil, the regular
                   ;; expression match should ignore case.
                   (progn
                     (setq
                      regexp (car regexpmatcher)
                      regexpmatcher (cdr regexpmatcher))
                     (unless (consp regexpmatcher)
                       ;; Malformed list: cdr of list is not a cons: Error.
                       (signal
                        'wrong-type-argument
                        (list 'consp regexpmatcher)))
                     ;; regexpmatcher is a cons.  It should be a
                     ;; one-element-list containing the value for
                     ;; case-fold-search:
                     (setq case-fold-search (car regexpmatcher))
                     ;; There shall be no further elements in the list:
                     (let ((tail (cdr regexpmatcher)))
                       (when tail
                         (error
                          "Surplus (=non-nil) tail of list: %S" tail))))
                 ;; else regexpmatcher should be the regular expression itself.
                 ;; Then case-fold-search remains nil.
                 (setq regexp regexpmatcher))
               (unless (stringp regexp)
                 (signal 'wrong-type-argument (list 'stringp regexp)))
               (and (string-match-p regexp account)
                    (let ((assignments (cdr-safe alistentry)))
                      (unless (listp assignments)
                        (signal
                         'wrong-type-argument (list 'listp assignments)))
                      assignments)))))
          configuration)))
       (newsymbols
        (make-vector (length my-messagesubmission-configuration-symbols) 0)))
    (while assignments
      (let* ((assignment (car assignments))
             ;; Each assignment shall be a non-empty list of 1 or 2
             ;; elements:
             ;;   1st element: the symbol.
             ;;   if 2nd element is available: the symbol's value,
	     ;;   if 2nd element is not available: the symbol's value is
	     ;;   void.
             ;; Otherwise: Error.
             (symbol (my-car-strict assignment))
             configsymbol)
        ;; Does the 1st list element denote a non-nil symbol?
        (unless (and symbol (symbolp symbol))
          ;; No non-nil symbol:
          (signal
           'wrong-type-argument
           (list
            (lambda (symbol) (and symbol (symbolp symbol)))
            symbol)))
        ;; Yes, the 1st list element denotes a non-nil symbol.
        ;; Is it a known configuration symbol?
	(let ((symbolname (symbol-name symbol)))
	  (cond
	   ((setq configsymbol
		  (intern-soft symbolname
			       my-messagesubmission-configuration-symbols)))
	   ;; Any user variables are permitted, too:
	   ((user-variable-p symbol)
	    (setq configsymbol (make-symbol symbolname))
	    (set configsymbol t))
	   (t
	    ;; This configuration symbol is unknown.
	    (error "%S is not a known configuration variable" symbol))))

        ;; Now, look at the rest of the assignment:
        (setq assignment (cdr assignment))
        ;; Depending on (symbol-value configsymbol), assignment either
        ;; may be an empty list, meaning: no assignment value, i.e. a
        ;; void variable.  Or it may be a one-element list, containing
        ;; the value.
	;; If (eq predicate nil), then there shall be no assignment value:
	;;    make the symbol unbound.
	;; If (eq predicate t), then there may be any optional assignment
	;;    value.
	;; Else there shall be an assignment value that satisfies
	;;    predicate.
        (let ((predicate (symbol-value configsymbol))
              (newsymbol (intern (symbol-name symbol) newsymbols)))
	  (cond
	   ((null assignment)
	    (unless (or (null predicate) (eq t predicate))
	      (error
	       "Missing value for the configuration variable %S"
	       newsymbol)))
	   ;; There is not an empty list (meaning: a void symbol).  So it
	   ;; should be a list of one element: the value to be assigned.
	   ((not (consp assignment))
	    ;; Malformed list: It is not a cons: Error.
	    (signal 'wrong-type-argument (list 'consp assignment)))
	   ;; It is a cons.  Value = (car assignment), whatever that is.
	   ;; Does the list continue after the value?
	   ((cdr assignment)
	    ;; Malformed list: more than one list element (the
	    ;; value).
	    (error "Surplus (=non-nil) tail of list: %S"
		   (cdr assignment)))
	   (t
	    ;; There is no surplus (=non-nil) tail of the list.  The list
	    ;; consists of one element, which is the value.
	    (let ((value (car assignment)))
	      (unless (or (eq predicate t) (funcall predicate value))
		(signal 'wrong-type-argument (list predicate value)))
	      (set newsymbol value))))))
      (setq assignments (cdr assignments)))
    newsymbols))

(defun my-messagesubmission-account nil
  "Get the MSA account info from \"X-My-MSA-Account\", \"Sender\", and \"From\".
These message headers are examined one after another in this sequence; and
the first of them, that exists, is used, to retrieve the message submission
account. The account info, e.g. e-mail-address, is extracted by the
function mail-extract-address-components."
  (let ((field
	 (let ((deactivate-mark deactivate-mark))
	   (save-excursion
	     (save-restriction
	       (message-narrow-to-headers)
	       (or (mail-fetch-field "X-My-MSA-Account" nil t)
		   (mail-fetch-field "Sender" nil t)
		   (mail-fetch-field "From" nil t)))))))
    (let ((addresses
	   (and field
		(mail-extract-address-components field t))))
      ;; Accept exactly one address only, not less or more:
      (let ((n (length addresses)))
	(if (equal n 1)
	    (cadar addresses)
	  (error
	   "There must be specified exactly one message submission account, not %S"
	   n)
	  )))))

(defun my-messagesubmission-X-My-MSA-Configuration nil
  "Get MSA configuration info from the \"X-My-MSA-Configuration\" header field.
The content of this message header is a list of keyword assignments like
those of the variable 'my-messagesubmission-configuration'.  For example,
there could be the header field
X-My-MSA-Configuration: ((smtpmail-smtp-server \"mail-provider.example\")
 (username \"me\"))"
  (let ((field
	 (let ((deactivate-mark deactivate-mark))
	   (save-excursion
	     (save-restriction
	       (message-narrow-to-headers)
	       (mail-fetch-field "X-My-MSA-Configuration" nil nil t))))))
    (let ((n (length field)))
      (cond
       ((equal n 0) nil)
       ((equal n 1) (read (car field)))
       (t
	(error
	 "In the message header field \"X-My-MSA-Configuration\",
there must be specified at most one list of message submission
configuration keyword assignments, not %S"
	 n))
	))))

(defun my-utils-copy-symbol-values
  (thevars From To)
  "For all THEVARS, copy a symbol-value from obarray FROM to obarray TO.
For each symbol in the obarray THEVARS, do the following:
  If there is a variable with the same name in FROM, intern a symbol with
  the same name into the obarray TO and assign it the symbol-value of the
  symbol in obarray FROM.
  If there is no variable with the same name in FROM, then, if there is a
  symbol with the same name in TO, make its symbol-value unbound.
The obarray TO is returned as the function's value."
  (mapatoms
   (cond
    ((eq thevars From)
     ;; Copy all variables in From, i.e. in the function in the
     ;; default case, below, there is (eq thevars From) and
     ;; (eq sourcesymbol symbol).
     (function
      (lambda (sourcesymbol)
	(let
	    ((symbolname (symbol-name sourcesymbol)))
	  (if (boundp sourcesymbol)
	      ;; Copy its value into a variable in the obarray To:
	      (set (intern symbolname To)
		   (symbol-value sourcesymbol))
	    ;; Else: If a destinationsymbol exists, make its value unbound:
	    (let ((destinationsymbol
		   (intern-soft symbolname To)))
	      (if destinationsymbol
		  (makunbound destinationsymbol))))))))
    ((eq thevars To)
     ;; Assign to all variables in To a value of the corresponding
     ;; symbol in From.  If the symbol in From does not exist
     ;; or has got no symbol-value, make the symbol in To unbound.
     (function
      (lambda (destinationsymbol)
	(let*
	    ((symbolname (symbol-name destinationsymbol))
	     (sourcesymbol
	      (intern-soft symbolname From)))
	  (if (and sourcesymbol (boundp sourcesymbol))
	      ;; sourcesymbol is a variable with the name of
	      ;; destinationsymbol. Copy its value into the variable in
	      ;; the obarray To:
	      (set destinationsymbol (symbol-value sourcesymbol))
	    ;; Else let the value of the corresponding variable in the
	    ;; obarray To be unbound.
	    (makunbound destinationsymbol))))))
    (t
     (function
      (lambda (symbol)
	(let*
	    ((symbolname (symbol-name symbol))
	     (sourcesymbol
	      (intern-soft symbolname From)))
	  (if (and sourcesymbol (boundp sourcesymbol))
	      ;; sourcesymbol is a variable with the name of
	      ;; symbol. Copy its value into a variable in the obarray
	      ;; To:
	      (set (intern symbolname To)
		   (symbol-value sourcesymbol))
	    ;; Else: If a destinationsymbol exists, make its value unbound:
	    (let ((destinationsymbol
		   (intern-soft symbolname To)))
	      (if destinationsymbol
		  (makunbound destinationsymbol)))))))))
   thevars))

(defun my-car-strict (cons)
  "signals error, iff cons is not a cons cell, else returns '(car cons)'."
  (if (consp cons)
      (car cons)
    (signal 'wrong-type-argument (list 'consp cons))))

(defun my-cdr-strict (cons)
  "signals error, iff cons is not a cons cell, else returns '(cdr cons)'."
  (if (consp cons)
      (cdr cons)
    (signal 'wrong-type-argument (list 'consp cons))))