code.delx.au - gnu-emacs/blob - lisp/url/url-privacy.el

   1 ;;; url-privacy.el --- Global history tracking for URL package
   2 ;; Keywords: comm, data, processes, hypermedia
   3
   4 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   5 ;;; Copyright (c) 1996 - 1999 Free Software Foundation, Inc.
   6 ;;;
   7 ;;; This file is part of GNU Emacs.
   8 ;;;
   9 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;;; it under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 2, or (at your option)
  12 ;;; any later version.
  13 ;;;
  14 ;;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;;; Boston, MA 02111-1307, USA.
  23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24
  25 (eval-when-compile (require 'cl))
  26 (require 'url-vars)
  27
  28 (if (fboundp 'device-type)
  29     (defalias 'url-device-type 'device-type)
  30   (defun url-device-type (&optional device) (or window-system 'tty)))
  31
  32 ;;;###autoload
  33 (defun url-setup-privacy-info ()
  34   (interactive)
  35   (setq url-system-type
  36         (cond
  37          ((or (eq url-privacy-level 'paranoid)
  38               (and (listp url-privacy-level)
  39                    (memq 'os url-privacy-level)))
  40           nil)
  41          ;; First, we handle the inseparable OS/Windowing system
  42          ;; combinations
  43          ((eq system-type 'Apple-Macintosh) "Macintosh")
  44          ((eq system-type 'next-mach) "NeXT")
  45          ((eq system-type 'windows-nt) "Windows-NT; 32bit")
  46          ((eq system-type 'ms-windows) "Windows; 16bit")
  47          ((eq system-type 'ms-dos) "MS-DOS; 32bit")
  48          ((memq (url-device-type) '(win32 w32)) "Windows; 32bit")
  49          ((eq (url-device-type) 'pm) "OS/2; 32bit")
  50          (t
  51           (case (url-device-type)
  52             (x "X11")
  53             (ns "OpenStep")
  54             (tty "TTY")
  55             (otherwise nil)))))
  56
  57   (setq url-personal-mail-address (or url-personal-mail-address
  58                                       user-mail-address
  59                                       (format "%s@%s"  (user-real-login-name)
  60                                               (system-name))))
  61
  62   (if (or (memq url-privacy-level '(paranoid high))
  63           (and (listp url-privacy-level)
  64                (memq 'email url-privacy-level)))
  65       (setq url-personal-mail-address nil))
  66
  67   (setq url-os-type
  68         (cond
  69          ((or (eq url-privacy-level 'paranoid)
  70               (and (listp url-privacy-level)
  71                    (memq 'os url-privacy-level)))
  72           nil)
  73          ((boundp 'system-configuration)
  74           system-configuration)
  75          ((boundp 'system-type)
  76           (symbol-name system-type))
  77          (t nil))))
  78
  79 (provide 'url-privacy)
  80
  81 ;;; arch-tag: fdaf95e4-98f0-4680-94c3-f3eadafabe1d