1;;; webmail.el --- interface of web mail 2 3;; Copyright (C) 1999, 2000, 2001, 2002, 2003, 2004, 4;; 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Author: Shenghuo Zhu <zsh@cs.rochester.edu> 7;; Keywords: hotmail netaddress my-deja netscape 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published 13;; by the Free Software Foundation; either version 2, or (at your 14;; option) any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, but 17;; WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 19;; General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;; Note: Now mail.yahoo.com provides POP3 service, the webmail 29;; fetching is not going to be supported. 30 31;; Note: You need to have `url' and `w3' installed for this backend to 32;; work. `w3' must be 4.0pre46+one-line-cookie patch or standalone 33;; `url'. 34 35;; Todo: To support more web mail servers. 36 37;; Known bugs: 38;; 1. Net@ddress may corrupt `X-Face'. 39 40;; Warning: 41;; Webmail is an experimental function, which means NO WARRANTY. 42 43;;; Code: 44 45(eval-when-compile (require 'cl)) 46 47(require 'nnoo) 48(require 'message) 49(require 'gnus-util) 50(require 'gnus) 51(require 'nnmail) 52(require 'mm-util) 53(require 'mm-url) 54(require 'mml) 55(eval-when-compile 56 (ignore-errors 57 (require 'url) 58 (require 'url-cookie))) 59;; Report failure to find w3 at load time if appropriate. 60(eval '(progn 61 (require 'url) 62 (require 'url-cookie))) 63 64;;; 65 66(defvar webmail-type-definition 67 '((hotmail 68 ;; Hotmail hate other HTTP user agents and use one line cookie 69 (paranoid agent cookie post) 70 (address . "www.hotmail.com") 71 (open-url "http://www.hotmail.com/") 72 (open-snarf . webmail-hotmail-open) 73 ;; W3 hate redirect POST 74 (login-url 75 "http://%s/cgi-bin/dologin?login=%s&passwd=%s&enter=Sign+in&sec=no&curmbox=ACTIVE&_lang=&js=yes&id=2&tw=-10000&beta=" 76 webmail-aux user password) 77 ;;(login-snarf . webmail-hotmail-login) 78 ;;(list-url "%s" webmail-aux) 79 (list-snarf . webmail-hotmail-list) 80 (article-snarf . webmail-hotmail-article) 81 (trash-url 82 "%s&login=%s&f=33792&curmbox=ACTIVE&_lang=&foo=inbox&js=&page=&%s=on&_HMaction=MoveTo&tobox=trAsH&nullbox=" 83 webmail-aux user id)) 84 (yahoo 85 (paranoid agent cookie post) 86 (address . "mail.yahoo.com") 87 (open-url "http://mail.yahoo.com/") 88 (open-snarf . webmail-yahoo-open) 89 (login-url;; yahoo will not accept GET 90 content 91 ("%s" webmail-aux) 92 ".tries=&.src=ym&.last=&promo=&.intl=&.bypass=&.partner=&.chkP=Y&.done=&login=%s&passwd=%s" 93 user password) 94 (login-snarf . webmail-yahoo-login) 95 (list-url "%s&rb=Inbox&YN=1" webmail-aux) 96 (list-snarf . webmail-yahoo-list) 97 (article-snarf . webmail-yahoo-article) 98 (trash-url 99 "%s/ym/ShowFolder?YY=52107&inc=50&order=down&sort=date&pos=0&box=Inbox&DEL=Delete&destBox=&Mid=%s&destBox2=" 100 webmail-aux id)) 101 (netaddress 102 (paranoid cookie post) 103 (address . "www.netaddress.com") 104 (open-url "http://www.netaddress.com/") 105 (open-snarf . webmail-netaddress-open) 106 (login-url 107 content 108 ("%s" webmail-aux) 109 "LoginState=2&SuccessfulLogin=%%2Ftpl&NewServerName=www.netaddress.com&JavaScript=JavaScript1.2&DomainID=4&Domain=usa.net&NA31site=classic.netaddress.com&NA31port=80&UserID=%s&passwd=%s" 110 user password) 111 (login-snarf . webmail-netaddress-login) 112 (list-url 113 "http://www.netaddress.com/tpl/Mail/%s/List?FolderID=-4&SortUseCase=True" 114 webmail-session) 115 (list-snarf . webmail-netaddress-list) 116 (article-url "http://www.netaddress.com/") 117 (article-snarf . webmail-netaddress-article) 118 (trash-url 119 "http://www.netaddress.com/tpl/Message/%s/Move?FolderID=-4&Q=%s&N=&Sort=Date&F=-1" 120 webmail-session id)) 121 (netscape 122 (paranoid cookie post agent) 123 (address . "webmail.netscape.com") 124 (open-url "http://ureg.netscape.com/iiop/UReg2/login/login?U2_LA=en&U2_BACK_FROM_CJ=true&U2_CS=iso-8859-1&U2_ENDURL=http://webmail.netscape.com/tpl/Subscribe/Step1&U2_NEW_ENDURL=http://webmail.netscape.com/tpl/Subscribe/Step1&U2_EXITURL=http://home.netscape.com/&U2_SOURCE=Webmail") 125 (open-snarf . webmail-netscape-open) 126 (login-url 127 content 128 ("http://ureg.netscape.com/iiop/UReg2/login/loginform") 129 "U2_USERNAME=%s&U2_PASSWORD=%s%s" 130 user password webmail-aux) 131 (login-snarf . webmail-netaddress-login) 132 (list-url 133 "http://webmail.netscape.com/tpl/Mail/%s/List?FolderID=-4&SortUseCase=True" 134 webmail-session) 135 (list-snarf . webmail-netaddress-list) 136 (article-url "http://webmail.netscape.com/") 137 (article-snarf . webmail-netscape-article) 138 (trash-url 139 "http://webmail.netscape.com/tpl/Message/%s/Move?FolderID=-4&Q=%s&N=&Sort=Date&F=-1" 140 webmail-session id)) 141 (my-deja 142 (paranoid cookie post) 143 (address . "www.my-deja.com") 144 ;;(open-snarf . webmail-my-deja-open) 145 (login-url 146 content 147 ("http://mydeja.google.com/cgi-bin/deja/maillogin.py") 148 "userid=%s&password=%s" 149 user password) 150 (list-snarf . webmail-my-deja-list) 151 (article-snarf . webmail-my-deja-article) 152 (trash-url webmail-aux id)))) 153 154(defvar webmail-variables 155 '(address article-snarf article-url list-snarf list-url 156 login-url login-snarf open-url open-snarf site articles 157 post-process paranoid trash-url)) 158 159(defconst webmail-version "webmail 1.0") 160 161(defvar webmail-newmail-only nil 162 "Only fetch new mails.") 163 164(defvar webmail-move-to-trash-can t 165 "Move mail to trash can after fetch it.") 166 167;;; Internal variables 168 169(defvar webmail-address nil) 170(defvar webmail-paranoid nil) 171(defvar webmail-aux nil) 172(defvar webmail-session nil) 173(defvar webmail-article-snarf nil) 174(defvar webmail-article-url nil) 175(defvar webmail-list-snarf nil) 176(defvar webmail-list-url nil) 177(defvar webmail-login-url nil) 178(defvar webmail-login-snarf nil) 179(defvar webmail-open-snarf nil) 180(defvar webmail-open-url nil) 181(defvar webmail-trash-url nil) 182(defvar webmail-articles nil) 183(defvar webmail-post-process nil) 184 185(defvar webmail-buffer nil) 186(defvar webmail-buffer-list nil) 187 188(defvar webmail-type nil) 189 190(defvar webmail-error-function nil) 191 192(defvar webmail-debug-file "~/.emacs-webmail-debug") 193 194;;; Interface functions 195 196(defun webmail-debug (str) 197 (with-temp-buffer 198 (insert "\n---------------- A bug at " str " ------------------\n") 199 (mapcar #'(lambda (sym) 200 (if (boundp sym) 201 (gnus-pp `(setq ,sym ',(eval sym))))) 202 '(webmail-type user)) 203 (insert "---------------- webmail buffer ------------------\n\n") 204 (insert-buffer-substring webmail-buffer) 205 (insert "\n---------------- end of buffer ------------------\n\n") 206 (append-to-file (point-min) (point-max) webmail-debug-file))) 207 208(defun webmail-error (str) 209 (if webmail-error-function 210 (funcall webmail-error-function str)) 211 (message "%s HTML has changed or your w3 package is too old.(%s)" 212 webmail-type str) 213 (error "%s HTML has changed or your w3 package is too old.(%s)" 214 webmail-type str)) 215 216(defun webmail-setdefault (type) 217 (let ((type-def (cdr (assq type webmail-type-definition))) 218 (vars webmail-variables) 219 pair) 220 (setq webmail-type type) 221 (dolist (var vars) 222 (if (setq pair (assq var type-def)) 223 (set (intern (concat "webmail-" (symbol-name var))) (cdr pair)) 224 (set (intern (concat "webmail-" (symbol-name var))) nil))))) 225 226(defun webmail-eval (expr) 227 (cond 228 ((consp expr) 229 (cons (webmail-eval (car expr)) (webmail-eval (cdr expr)))) 230 ((symbolp expr) 231 (eval expr)) 232 (t 233 expr))) 234 235(defun webmail-url (xurl) 236 (mm-with-unibyte-current-buffer 237 (cond 238 ((eq (car xurl) 'content) 239 (pop xurl) 240 (mm-url-fetch-simple (if (stringp (car xurl)) 241 (car xurl) 242 (apply 'format (webmail-eval (car xurl)))) 243 (apply 'format (webmail-eval (cdr xurl))))) 244 ((eq (car xurl) 'post) 245 (pop xurl) 246 (mm-url-fetch-form (car xurl) (webmail-eval (cdr xurl)))) 247 (t 248 (mm-url-insert (apply 'format (webmail-eval xurl))))))) 249 250(defun webmail-init () 251 "Initialize buffers and such." 252 (if (gnus-buffer-live-p webmail-buffer) 253 (set-buffer webmail-buffer) 254 (setq webmail-buffer 255 (nnheader-set-temp-buffer " *webmail*")) 256 (mm-disable-multibyte))) 257 258(defvar url-package-name) 259(defvar url-package-version) 260(defvar url-cookie-multiple-line) 261(defvar url-confirmation-func) 262 263;; Hack W3 POST redirect. See `url-parse-mime-headers'. 264;; 265;; Netscape uses "GET" as redirect method when orignal method is POST 266;; and status is 302, .i.e no security risks by default without 267;; confirmation. 268;; 269;; Some web servers (at least Apache used by yahoo) return status 302 270;; instead of 303, though they mean 303. 271 272(defun webmail-url-confirmation-func (prompt) 273 (cond 274 ((equal prompt (concat "Honor redirection with non-GET method " 275 "(possible security risks)? ")) 276 nil) 277 ((equal prompt "Continue (with method of GET)? ") 278 t) 279 (t (error prompt)))) 280 281(defun webmail-refresh-redirect () 282 "Redirect refresh url in META." 283 (goto-char (point-min)) 284 (while (re-search-forward 285 "<meta[ \t\r\n]*http-equiv=\"Refresh\"[^>]*URL=\\([^\"]+\\)\"" 286 nil t) 287 (let ((url (match-string 1))) 288 (erase-buffer) 289 (mm-with-unibyte-current-buffer 290 (mm-url-insert url))) 291 (goto-char (point-min)))) 292 293(defun webmail-fetch (file subtype user password) 294 (save-excursion 295 (webmail-setdefault subtype) 296 (let ((url-package-name (if (memq 'agent webmail-paranoid) 297 "Mozilla" 298 url-package-name)) 299 (url-package-version (if (memq 'agent webmail-paranoid) 300 "4.0" 301 url-package-version)) 302 (url-cookie-multiple-line (if (memq 'cookie webmail-paranoid) 303 nil 304 url-cookie-multiple-line)) 305 (url-confirmation-func (if (memq 'post webmail-paranoid) 306 'webmail-url-confirmation-func 307 url-confirmation-func)) 308 (url-http-silence-on-insecure-redirection t) 309 url-cookie-storage url-cookie-secure-storage 310 url-cookie-confirmation 311 item id (n 0)) 312 (webmail-init) 313 (setq webmail-articles nil) 314 (when webmail-open-url 315 (erase-buffer) 316 (webmail-url webmail-open-url)) 317 (if webmail-open-snarf (funcall webmail-open-snarf)) 318 (when webmail-login-url 319 (erase-buffer) 320 (webmail-url webmail-login-url)) 321 (if webmail-login-snarf 322 (funcall webmail-login-snarf)) 323 (when webmail-list-url 324 (erase-buffer) 325 (webmail-url webmail-list-url)) 326 (if webmail-list-snarf 327 (funcall webmail-list-snarf)) 328 (while (setq item (pop webmail-articles)) 329 (message "Fetching mail #%d..." (setq n (1+ n))) 330 (erase-buffer) 331 (mm-with-unibyte-current-buffer 332 (mm-url-insert (cdr item))) 333 (setq id (car item)) 334 (if webmail-article-snarf 335 (funcall webmail-article-snarf file id)) 336 (when (and webmail-trash-url webmail-move-to-trash-can) 337 (message "Move mail #%d to trash can..." n) 338 (condition-case err 339 (progn 340 (webmail-url webmail-trash-url) 341 (let (buf) 342 (while (setq buf (pop webmail-buffer-list)) 343 (kill-buffer buf)))) 344 (error 345 (let (buf) 346 (while (setq buf (pop webmail-buffer-list)) 347 (kill-buffer buf))) 348 (error err)))))) 349 (if webmail-post-process 350 (funcall webmail-post-process)))) 351 352(defun webmail-encode-8bit () 353 (goto-char (point-min)) 354 (skip-chars-forward "^\200-\377") 355 (while (not (eobp)) 356 (insert (format "&%d;" (mm-char-int (char-after)))) 357 (delete-char 1) 358 (skip-chars-forward "^\200-\377"))) 359 360;;; hotmail 361 362(defun webmail-hotmail-open () 363 (goto-char (point-min)) 364 (if (re-search-forward 365 "action=\"https?://\\([^/]+\\)/cgi-bin/dologin" nil t) 366 (setq webmail-aux (match-string 1)) 367 (webmail-error "open@1"))) 368 369(defun webmail-hotmail-login () 370 (let (site) 371 (goto-char (point-min)) 372 (if (re-search-forward 373 "https?://\\([^/]+hotmail\\.msn\\.com\\)/cgi-bin/" nil t) 374 (setq site (match-string 1)) 375 (webmail-error "login@1")) 376 (goto-char (point-min)) 377 (if (re-search-forward 378 "\\(/cgi-bin/HoTMaiL\\?[^\"]*a=b[^\"]*\\)" nil t) 379 (setq webmail-aux (concat "http://" site (match-string 1))) 380 (webmail-error "login@2")))) 381 382(defun webmail-hotmail-list () 383 (goto-char (point-min)) 384 (skip-chars-forward " \t\n\r") 385 (let (site url newp (total "0")) 386 (if (eobp) 387 (setq total "0") 388 (if (re-search-forward "\\([0-9]+\\) *<b>(\\([0-9]+\\) new)" nil t) 389 (message "Found %s (%s new)" (setq total (match-string 1)) 390 (match-string 2)) 391 (if (re-search-forward "\\([0-9]+\\) new" nil t) 392 (message "Found %s new" (setq total (match-string 1))) 393 (webmail-error "list@0")))) 394 (unless (equal total "0") 395 (goto-char (point-min)) 396 (if (re-search-forward 397 "https?://\\([^/]+hotmail\\.msn\\.com\\)/cgi-bin/" nil t) 398 (setq site (match-string 1)) 399 (webmail-error "list@1")) 400 (goto-char (point-min)) 401 (if (re-search-forward "disk=\\([^&]*\\)&" nil t) 402 (setq webmail-aux 403 (concat "http://" site "/cgi-bin/HoTMaiL?disk=" 404 (match-string 1))) 405 (webmail-error "list@2")) 406 (goto-char (point-max)) 407 (while (re-search-backward 408 "newmail\\.gif\\|href=\"\\(/cgi-bin/getmsg\\?[^\"]+\\)\"" 409 nil t) 410 (if (setq url (match-string 1)) 411 (progn 412 (if (or newp (not webmail-newmail-only)) 413 (let (id) 414 (if (string-match "msg=\\([^&]+\\)" url) 415 (setq id (match-string 1 url))) 416 (push (cons id (concat "http://" site url "&raw=0")) 417 webmail-articles))) 418 (setq newp nil)) 419 (setq newp t)))))) 420 421;; Thank victor@idaccr.org (Victor S. Miller) for raw=0 422 423(defun webmail-hotmail-article (file id) 424 (goto-char (point-min)) 425 (skip-chars-forward " \t\n\r") 426 (unless (eobp) 427 (if (not (search-forward "<pre>" nil t)) 428 (webmail-error "article@3")) 429 (skip-chars-forward "\n\r\t ") 430 (delete-region (point-min) (point)) 431 (if (not (search-forward "</pre>" nil t)) 432 (webmail-error "article@3.1")) 433 (delete-region (match-beginning 0) (point-max)) 434 (mm-url-remove-markup) 435 (mm-url-decode-entities-nbsp) 436 (goto-char (point-min)) 437 (while (re-search-forward "\r\n?" nil t) 438 (replace-match "\n")) 439 (goto-char (point-min)) 440 (insert "\n\n") 441 (if (not (looking-at "\n*From ")) 442 (insert "From nobody " (current-time-string) "\n") 443 (forward-line)) 444 (insert "X-Gnus-Webmail: " (symbol-value 'user) 445 "@" (symbol-name webmail-type) "\n") 446 (mm-append-to-file (point-min) (point-max) file))) 447 448(defun webmail-hotmail-article-old (file id) 449 (let (p attachment count mime hotmail-direct) 450 (save-restriction 451 (webmail-encode-8bit) 452 (goto-char (point-min)) 453 (if (not (search-forward "<DIV>" nil t)) 454 (if (not (search-forward "Reply All" nil t)) 455 (webmail-error "article@1") 456 (setq hotmail-direct t)) 457 (goto-char (match-beginning 0))) 458 (narrow-to-region (point-min) (point)) 459 (if (not (search-backward "<table" nil t 2)) 460 (webmail-error "article@1.1")) 461 (delete-region (point-min) (match-beginning 0)) 462 (while (search-forward "<a href=" nil t) 463 (setq p (match-beginning 0)) 464 (search-forward "</a>" nil t) 465 (delete-region p (match-end 0))) 466 (mm-url-remove-markup) 467 (mm-url-decode-entities-nbsp) 468 (goto-char (point-min)) 469 (delete-blank-lines) 470 (goto-char (point-min)) 471 (when (search-forward "\n\n" nil t) 472 (backward-char) 473 (delete-region (point) (point-max))) 474 (goto-char (point-max)) 475 (widen) 476 (insert "\n") 477 (setq p (point)) 478 (while (re-search-forward 479 "<tt>\\|<div>\\|\\(http://[^/]+/cgi-bin/getmsg/\\([^\?]+\\)\?[^\"]*\\)\"" 480 nil t) 481 (if (setq attachment (match-string 1)) 482 (let ((filename (match-string 2)) 483 bufname);; Attachment 484 (delete-region p (match-end 0)) 485 (save-excursion 486 (set-buffer (generate-new-buffer " *webmail-att*")) 487 (mm-url-insert attachment) 488 (push (current-buffer) webmail-buffer-list) 489 (setq bufname (buffer-name))) 490 (setq mime t) 491 (insert "<#part type=" 492 (or (and filename 493 (string-match "\\.[^\\.]+$" filename) 494 (mailcap-extension-to-mime 495 (match-string 0 filename))) 496 "application/octet-stream")) 497 (insert " buffer=\"" bufname "\"") 498 (insert " filename=\"" filename "\"") 499 (insert " disposition=\"inline\"") 500 (insert "><#/part>\n") 501 (setq p (point))) 502 (delete-region p (match-end 0)) 503 (if hotmail-direct 504 (if (not (search-forward "</tt>" nil t)) 505 (webmail-error "article@1.2") 506 (delete-region (match-beginning 0) (match-end 0))) 507 (setq count 1) 508 (while (and (> count 0) 509 (re-search-forward "</div>\\|\\(<div>\\)" nil t)) 510 (if (match-string 1) 511 (setq count (1+ count)) 512 (if (= (setq count (1- count)) 0) 513 (delete-region (match-beginning 0) 514 (match-end 0)))))) 515 (narrow-to-region p (point)) 516 (goto-char (point-min)) 517 (cond 518 ((looking-at "<pre>") 519 (goto-char (match-end 0)) 520 (if (looking-at "$") (forward-char)) 521 (delete-region (point-min) (point)) 522 (mm-url-remove-markup) 523 (mm-url-decode-entities-nbsp) 524 nil) 525 (t 526 (setq mime t) 527 (insert "<#part type=\"text/html\" disposition=inline>") 528 (goto-char (point-max)) 529 (insert "<#/part>"))) 530 (goto-char (point-max)) 531 (setq p (point)) 532 (widen))) 533 (delete-region p (point-max)) 534 (goto-char (point-min)) 535 ;; Some blank line to seperate mails. 536 (insert "\n\nFrom nobody " (current-time-string) "\n") 537 (insert "X-Gnus-Webmail: " (symbol-value 'user) 538 "@" (symbol-name webmail-type) "\n") 539 (if id 540 (insert (format "X-Message-ID: <%s@hotmail.com>\n" id))) 541 (unless (looking-at "$") 542 (if (search-forward "\n\n" nil t) 543 (forward-line -1) 544 (webmail-error "article@2"))) 545 (narrow-to-region (point) (point-max)) 546 (if mime 547 (insert "MIME-Version: 1.0\n" 548 (prog1 549 (mml-generate-mime) 550 (delete-region (point-min) (point-max))))) 551 (goto-char (point-min)) 552 (widen) 553 (let (case-fold-search) 554 (while (re-search-forward "^From " nil t) 555 (beginning-of-line) 556 (insert ">")))) 557 (mm-append-to-file (point-min) (point-max) file))) 558 559;;; yahoo 560 561(defun webmail-yahoo-open () 562 (goto-char (point-min)) 563 (if (re-search-forward "action=\"\\([^\"]+\\)\"" nil t) 564 (setq webmail-aux (match-string 1)) 565 (webmail-error "open@1"))) 566 567(defun webmail-yahoo-login () 568 (goto-char (point-min)) 569 (if (re-search-forward "http://[^/]+[0-9]\\.mail\\.yahoo\\.com/" nil t) 570 (setq webmail-aux (match-string 0)) 571 (webmail-error "login@1")) 572 (if (re-search-forward "YY=[0-9]+" nil t) 573 (setq webmail-aux (concat webmail-aux "ym/ShowFolder?" 574 (match-string 0))) 575 (webmail-error "login@2"))) 576 577(defun webmail-yahoo-list () 578 (let (url (newp t) (tofetch 0)) 579 (goto-char (point-min)) 580 (when (re-search-forward 581 "showing [0-9]+-\\([0-9]+\\) of \\([0-9]+\\)" nil t) 582 ;;(setq listed (match-string 1)) 583 (message "Found %s mail(s)" (match-string 2))) 584 (if (string-match "http://[^/]+" webmail-aux) 585 (setq webmail-aux (match-string 0 webmail-aux)) 586 (webmail-error "list@1")) 587 (goto-char (point-min)) 588 (while (re-search-forward 589 "bgcolor=\"#eeeeee\"\\|href=\"\\(/ym/ShowLetter\\?MsgId=\\([^&]+\\)&[^\"]*\\)\"" 590 nil t) 591 (if (setq url (match-string 1)) 592 (progn 593 (when (or newp (not webmail-newmail-only)) 594 (push (cons (match-string 2) (concat webmail-aux url "&toc=1")) 595 webmail-articles) 596 (setq tofetch (1+ tofetch))) 597 (setq newp t)) 598 (setq newp nil))) 599 (setq webmail-articles (nreverse webmail-articles)) 600 (message "Fetching %d mail(s)" tofetch))) 601 602(defun webmail-yahoo-article (file id) 603 (let (p attachment) 604 (save-restriction 605 (goto-char (point-min)) 606 (if (not (search-forward "value=\"Done\"" nil t)) 607 (webmail-error "article@1")) 608 (if (not (search-forward "<table" nil t)) 609 (webmail-error "article@2")) 610 (delete-region (point-min) (match-beginning 0)) 611 (if (not (search-forward "</table>" nil t)) 612 (webmail-error "article@3")) 613 (narrow-to-region (point-min) (match-end 0)) 614 (while (search-forward "<a href=" nil t) 615 (setq p (match-beginning 0)) 616 (search-forward "</a>" nil t) 617 (delete-region p (match-end 0))) 618 (mm-url-remove-markup) 619 (mm-url-decode-entities-nbsp) 620 (goto-char (point-min)) 621 (delete-blank-lines) 622 (goto-char (point-max)) 623 (widen) 624 (insert "\n") 625 (setq p (point)) 626 (while (re-search-forward "[^\"]*/ShowLetter/[^\?]+\?[^\"]*" nil t) 627 (setq attachment (match-string 0)) 628 (let (bufname ct ctl cd description) 629 (if (not (search-forward "<table" nil t)) 630 (webmail-error "article@4")) 631 (delete-region p (match-beginning 0)) 632 (if (not (search-forward "</table>" nil t)) 633 (webmail-error "article@5")) 634 (narrow-to-region p (match-end 0)) 635 (mm-url-remove-markup) 636 (mm-url-decode-entities-nbsp) 637 (goto-char (point-min)) 638 (delete-blank-lines) 639 (setq ct (mail-fetch-field "content-type") 640 ctl (and ct (mail-header-parse-content-type ct)) 641 ;;cte (mail-fetch-field "content-transfer-encoding") 642 cd (mail-fetch-field "content-disposition") 643 description (mail-fetch-field "content-description") 644 id (mail-fetch-field "content-id")) 645 (delete-region (point-min) (point-max)) 646 (widen) 647 (save-excursion 648 (set-buffer (generate-new-buffer " *webmail-att*")) 649 (mm-url-insert (concat webmail-aux attachment)) 650 (push (current-buffer) webmail-buffer-list) 651 (setq bufname (buffer-name))) 652 (insert "<#part") 653 (if (and ctl (not (equal (car ctl) "text/"))) 654 (insert " type=\"" (car ctl) "\"")) 655 (insert " buffer=\"" bufname "\"") 656 (if cd 657 (insert " disposition=\"" cd "\"")) 658 (if description 659 (insert " description=\"" description "\"")) 660 (insert "><#/part>\n") 661 (setq p (point)))) 662 (delete-region p (point-max)) 663 (goto-char (point-min)) 664 ;; Some blank line to seperate mails. 665 (insert "\n\nFrom nobody " (current-time-string) "\n") 666 (insert "X-Gnus-Webmail: " (symbol-value 'user) 667 "@" (symbol-name webmail-type) "\n") 668 (if id 669 (insert (format "X-Message-ID: <%s@yahoo.com>\n" id))) 670 (unless (looking-at "$") 671 (if (search-forward "\n\n" nil t) 672 (forward-line -1) 673 (webmail-error "article@2"))) 674 (narrow-to-region (point) (point-max)) 675 (insert "MIME-Version: 1.0\n" 676 (prog1 677 (mml-generate-mime) 678 (delete-region (point-min) (point-max)))) 679 (goto-char (point-min)) 680 (widen) 681 (let (case-fold-search) 682 (while (re-search-forward "^From " nil t) 683 (beginning-of-line) 684 (insert ">")))) 685 (mm-append-to-file (point-min) (point-max) file))) 686 687;;; netaddress 688 689(defun webmail-netscape-open () 690 (goto-char (point-min)) 691 (setq webmail-aux "") 692 (while (re-search-forward 693 "TYPE=hidden *NAME=\\([^ ]+\\) *VALUE=\"\\([^\"]+\\)" 694 nil t) 695 (setq webmail-aux (concat webmail-aux "&" (match-string 1) "=" 696 (match-string 2))))) 697 698(defun webmail-netaddress-open () 699 (goto-char (point-min)) 700 (if (re-search-forward "action=\"\\([^\"]+\\)\"" nil t) 701 (setq webmail-aux (concat (car webmail-open-url) (match-string 1))) 702 (webmail-error "open@1"))) 703 704(defun webmail-netaddress-login () 705 (webmail-refresh-redirect) 706 (goto-char (point-min)) 707 (if (re-search-forward "tpl/[^/]+/\\([^/]+\\)" nil t) 708 (setq webmail-session (match-string 1)) 709 (webmail-error "login@1"))) 710 711(defun webmail-netaddress-list () 712 (webmail-refresh-redirect) 713 (let (item id) 714 (goto-char (point-min)) 715 (when (re-search-forward 716 "(\\([0-9]+\\) unread, \\([0-9]+\\) total)" nil t) 717 (message "Found %s mail(s), %s unread" 718 (match-string 2) (match-string 1))) 719 (goto-char (point-min)) 720 (while (re-search-forward 721 "MR\\[i\\]\\.R='\\([^']*\\)'\\|MR\\[i\\]\\.Q='\\([^']+\\)'" nil t) 722 (if (setq id (match-string 2)) 723 (setq item 724 (cons id 725 (format "%s/tpl/Message/%s/Read?Q=%s&FolderID=-4&SortUseCase=True&Sort=Date&Headers=True" 726 (car webmail-article-url) 727 webmail-session id))) 728 (if (or (not webmail-newmail-only) 729 (equal (match-string 1) "True")) 730 (push item webmail-articles)))) 731 (setq webmail-articles (nreverse webmail-articles)))) 732 733(defun webmail-netaddress-single-part () 734 (goto-char (point-min)) 735 (cond 736 ((looking-at "[\t\040\r\n]*<font face=[^>]+>[\t\040\r\n]*") 737 ;; text/plain 738 (replace-match "") 739 (while (re-search-forward "[\t\040\r\n]+" nil t) 740 (replace-match " ")) 741 (goto-char (point-min)) 742 (while (re-search-forward "<br>" nil t) 743 (replace-match "\n")) 744 (mm-url-remove-markup) 745 (mm-url-decode-entities-nbsp) 746 nil) 747 (t 748 (insert "<#part type=\"text/html\" disposition=inline>") 749 (goto-char (point-max)) 750 (insert "<#/part>") 751 t))) 752 753(defun webmail-netaddress-article (file id) 754 (webmail-refresh-redirect) 755 (let (p p1 attachment count mime type) 756 (save-restriction 757 (webmail-encode-8bit) 758 (goto-char (point-min)) 759 (if (not (search-forward "Trash" nil t)) 760 (webmail-error "article@1")) 761 (if (not (search-forward "<form>" nil t)) 762 (webmail-error "article@2")) 763 (delete-region (point-min) (match-beginning 0)) 764 (if (not (search-forward "</form>" nil t)) 765 (webmail-error "article@3")) 766 (narrow-to-region (point-min) (match-end 0)) 767 (goto-char (point-min)) 768 (while (re-search-forward "[\040\t\r\n]+" nil t) 769 (replace-match " ")) 770 (goto-char (point-min)) 771 (while (search-forward "<b>" nil t) 772 (replace-match "\n")) 773 (mm-url-remove-markup) 774 (mm-url-decode-entities-nbsp) 775 (goto-char (point-min)) 776 (delete-blank-lines) 777 (goto-char (point-min)) 778 (while (re-search-forward "^\040+\\|\040+$" nil t) 779 (replace-match "")) 780 (goto-char (point-min)) 781 (while (re-search-forward "\040+" nil t) 782 (replace-match " ")) 783 (goto-char (point-max)) 784 (widen) 785 (insert "\n\n") 786 (setq p (point)) 787 (unless (search-forward "<!-- Data -->" nil t) 788 (webmail-error "article@4")) 789 (forward-line 14) 790 (delete-region p (point)) 791 (goto-char (point-max)) 792 (unless (re-search-backward 793 "[\040\t]*<br>[\040\t\r\n]*<br>[\040\t\r\n]*<form" p t) 794 (webmail-error "article@5")) 795 (delete-region (point) (point-max)) 796 (goto-char p) 797 (while (search-forward 798 "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>" 799 nil t 2) 800 (setq mime t) 801 (unless (search-forward "</TABLE>" nil t) 802 (webmail-error "article@6")) 803 (setq p1 (point)) 804 (if (search-backward "<IMG " p t) 805 (progn 806 (unless (re-search-forward "HREF=\"\\(/tpl/Attachment/[^/]+/\\([^/]+/[^\?]+\\)[^\"]+\\)\"" p1 t) 807 (webmail-error "article@7")) 808 (setq attachment (match-string 1)) 809 (setq type (match-string 2)) 810 (unless (search-forward "</TABLE>" nil t) 811 (webmail-error "article@8")) 812 (delete-region p (point)) 813 (let (bufname);; Attachment 814 (save-excursion 815 (set-buffer (generate-new-buffer " *webmail-att*")) 816 (mm-url-insert (concat (car webmail-open-url) attachment)) 817 (push (current-buffer) webmail-buffer-list) 818 (setq bufname (buffer-name))) 819 (insert "<#part type=" type) 820 (insert " buffer=\"" bufname "\"") 821 (insert " disposition=\"inline\"") 822 (insert "><#/part>\n") 823 (setq p (point)))) 824 (delete-region p p1) 825 (narrow-to-region 826 p 827 (if (search-forward 828 "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>" 829 nil t) 830 (match-beginning 0) 831 (point-max))) 832 (webmail-netaddress-single-part) 833 (goto-char (point-max)) 834 (setq p (point)) 835 (widen))) 836 (unless mime 837 (narrow-to-region p (point-max)) 838 (setq mime (webmail-netaddress-single-part)) 839 (widen)) 840 (goto-char (point-min)) 841 ;; Some blank line to seperate mails. 842 (insert "\n\nFrom nobody " (current-time-string) "\n") 843 (insert "X-Gnus-Webmail: " (symbol-value 'user) 844 "@" (symbol-name webmail-type) "\n") 845 (if id 846 (insert (format "X-Message-ID: <%s@%s>\n" id webmail-address))) 847 (unless (looking-at "$") 848 (if (search-forward "\n\n" nil t) 849 (forward-line -1) 850 (webmail-error "article@2"))) 851 (when mime 852 (narrow-to-region (point-min) (point)) 853 (goto-char (point-min)) 854 (while (not (eobp)) 855 (if (looking-at "MIME-Version\\|Content-Type") 856 (delete-region (point) 857 (progn 858 (forward-line 1) 859 (if (re-search-forward "^[^ \t]" nil t) 860 (goto-char (match-beginning 0)) 861 (point-max)))) 862 (forward-line 1))) 863 (goto-char (point-max)) 864 (widen) 865 (narrow-to-region (point) (point-max)) 866 (insert "MIME-Version: 1.0\n" 867 (prog1 868 (mml-generate-mime) 869 (delete-region (point-min) (point-max)))) 870 (goto-char (point-min)) 871 (widen)) 872 (let (case-fold-search) 873 (while (re-search-forward "^From " nil t) 874 (beginning-of-line) 875 (insert ">")))) 876 (mm-append-to-file (point-min) (point-max) file))) 877 878(defun webmail-netscape-article (file id) 879 (let (p p1 attachment count mime type) 880 (save-restriction 881 (webmail-encode-8bit) 882 (goto-char (point-min)) 883 (if (not (search-forward "Trash" nil t)) 884 (webmail-error "article@1")) 885 (if (not (search-forward "<form>" nil t)) 886 (webmail-error "article@2")) 887 (delete-region (point-min) (match-beginning 0)) 888 (if (not (search-forward "</form>" nil t)) 889 (webmail-error "article@3")) 890 (narrow-to-region (point-min) (match-end 0)) 891 (goto-char (point-min)) 892 (while (re-search-forward "[\040\t\r\n]+" nil t) 893 (replace-match " ")) 894 (goto-char (point-min)) 895 (while (re-search-forward "<a href=[^>]*>[^<]*</a>" nil t) 896 (replace-match "")) 897 (goto-char (point-min)) 898 (while (search-forward "<b>" nil t) 899 (replace-match "\n")) 900 (mm-url-remove-markup) 901 (mm-url-decode-entities-nbsp) 902 (goto-char (point-min)) 903 (delete-blank-lines) 904 (goto-char (point-min)) 905 (while (re-search-forward "^\040+\\|\040+$" nil t) 906 (replace-match "")) 907 (goto-char (point-min)) 908 (while (re-search-forward "\040+" nil t) 909 (replace-match " ")) 910 (goto-char (point-max)) 911 (widen) 912 (insert "\n\n") 913 (setq p (point)) 914 (unless (search-forward "<!-- Data -->" nil t) 915 (webmail-error "article@4")) 916 (forward-line 14) 917 (delete-region p (point)) 918 (goto-char (point-max)) 919 (unless (re-search-backward 920 "<form name=\"Transfer2\"" p t) 921 (webmail-error "article@5")) 922 (delete-region (point) (point-max)) 923 (goto-char p) 924 (while (search-forward 925 "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>" 926 nil t 2) 927 (setq mime t) 928 (unless (search-forward "</TABLE>" nil t) 929 (webmail-error "article@6")) 930 (setq p1 (point)) 931 (if (search-backward "<IMG " p t) 932 (progn 933 (unless (re-search-forward "HREF=\"\\(/tpl/Attachment/[^/]+/\\([^/]+/[^\?]+\\)[^\"]+\\)\"" p1 t) 934 (webmail-error "article@7")) 935 (setq attachment (match-string 1)) 936 (setq type (match-string 2)) 937 (unless (search-forward "</TABLE>" nil t) 938 (webmail-error "article@8")) 939 (delete-region p (point)) 940 (let (bufname);; Attachment 941 (save-excursion 942 (set-buffer (generate-new-buffer " *webmail-att*")) 943 (mm-url-insert (concat (car webmail-open-url) attachment)) 944 (push (current-buffer) webmail-buffer-list) 945 (setq bufname (buffer-name))) 946 (insert "<#part type=" type) 947 (insert " buffer=\"" bufname "\"") 948 (insert " disposition=\"inline\"") 949 (insert "><#/part>\n") 950 (setq p (point)))) 951 (delete-region p p1) 952 (narrow-to-region 953 p 954 (if (search-forward 955 "<TABLE border=\"0\" WIDTH=\"98%\" cellpadding=0 cellspacing=0>" 956 nil t) 957 (match-beginning 0) 958 (point-max))) 959 (webmail-netaddress-single-part) 960 (goto-char (point-max)) 961 (setq p (point)) 962 (widen))) 963 (unless mime 964 (narrow-to-region p (point-max)) 965 (setq mime (webmail-netaddress-single-part)) 966 (widen)) 967 (goto-char (point-min)) 968 ;; Some blank line to seperate mails. 969 (insert "\n\nFrom nobody " (current-time-string) "\n") 970 (insert "X-Gnus-Webmail: " (symbol-value 'user) 971 "@" (symbol-name webmail-type) "\n") 972 (if id 973 (insert (format "X-Message-ID: <%s@%s>\n" id webmail-address))) 974 (unless (looking-at "$") 975 (if (search-forward "\n\n" nil t) 976 (forward-line -1) 977 (webmail-error "article@2"))) 978 (when mime 979 (narrow-to-region (point-min) (point)) 980 (goto-char (point-min)) 981 (while (not (eobp)) 982 (if (looking-at "MIME-Version\\|Content-Type") 983 (delete-region (point) 984 (progn 985 (forward-line 1) 986 (if (re-search-forward "^[^ \t]" nil t) 987 (goto-char (match-beginning 0)) 988 (point-max)))) 989 (forward-line 1))) 990 (goto-char (point-max)) 991 (widen) 992 (narrow-to-region (point) (point-max)) 993 (insert "MIME-Version: 1.0\n" 994 (prog1 995 (mml-generate-mime) 996 (delete-region (point-min) (point-max)))) 997 (goto-char (point-min)) 998 (widen)) 999 (let (case-fold-search) 1000 (while (re-search-forward "^From " nil t) 1001 (beginning-of-line) 1002 (insert ">")))) 1003 (mm-append-to-file (point-min) (point-max) file))) 1004 1005;;; my-deja 1006 1007(defun webmail-my-deja-open () 1008 (webmail-refresh-redirect) 1009 (goto-char (point-min)) 1010 (if (re-search-forward "action=\"\\([^\"]+maillogin\\.py[^\"]*\\)\"" 1011 nil t) 1012 (setq webmail-aux (match-string 1)) 1013 (webmail-error "open@1"))) 1014 1015(defun webmail-my-deja-list () 1016 (let (item id newp base) 1017 (goto-char (point-min)) 1018 (when (re-search-forward "href=\"\\(\\([^\"]*\\)/mailnf\\.[^\"]*\\)\"" 1019 nil t) 1020 (let ((url (match-string 1))) 1021 (setq base (match-string 2)) 1022 (erase-buffer) 1023 (mm-url-insert url))) 1024 (goto-char (point-min)) 1025 (when (re-search-forward 1026 "(\\([0-9]+\\) Message.?-[^>]*\\([0-9]+\\) New" 1027 nil t) 1028 (message "Found %s mail(s), %s unread" 1029 (match-string 1) (match-string 2))) 1030 (goto-char (point-min)) 1031 (while (re-search-forward 1032 "newmail\\.gif\\|href=\"[^\"]*\\(mailnf\\.[^\"]+act=view[^\"]+mid=\\([^\"&]+\\)[^\"]+\\)\"" 1033 nil t) 1034 (if (setq id (match-string 2)) 1035 (when (and (or newp (not webmail-newmail-only)) 1036 (not (assoc id webmail-articles))) 1037 (push (cons id (setq webmail-aux 1038 (concat base "/" (match-string 1)))) 1039 webmail-articles) 1040 (setq newp nil)) 1041 (setq newp t))) 1042 (setq webmail-articles (nreverse webmail-articles)))) 1043 1044(defun webmail-my-deja-article-part (base) 1045 (let (p) 1046 (cond 1047 ((looking-at "[\t\040\r\n]*<!--[^>]*>") 1048 (replace-match "")) 1049 ((looking-at "[\t\040\r\n]*</PRE>") 1050 (replace-match "")) 1051 ((looking-at "[\t\040\r\n]*<PRE>") 1052 ;; text/plain 1053 (replace-match "") 1054 (save-restriction 1055 (narrow-to-region (point) 1056 (if (re-search-forward "</?PRE>" nil t) 1057 (match-beginning 0) 1058 (point-max))) 1059 (goto-char (point-min)) 1060 (mm-url-remove-markup) 1061 (mm-url-decode-entities-nbsp) 1062 (goto-char (point-max)))) 1063 ((looking-at "[\t\040\r\n]*<TABLE") 1064 (save-restriction 1065 (narrow-to-region (point) 1066 (if (search-forward "</TABLE>" nil t 2) 1067 (point) 1068 (point-max))) 1069 (goto-char (point-min)) 1070 (let (name type url bufname) 1071 (if (and (search-forward "File Name:" nil t) 1072 (re-search-forward "<FONT[^>]+>\\([^<]+\\)" nil t)) 1073 (setq name (match-string 1))) 1074 (if (and (search-forward "File Type:" nil t) 1075 (re-search-forward "<FONT[^>]+>\\([^<]+\\)" nil t)) 1076 (setq type (match-string 1))) 1077 (unless (re-search-forward "action=\"getattach\\.cgi/\\([^\"]+\\)" 1078 nil t) 1079 (webmail-error "article@5")) 1080 (setq url (concat base "/getattach.cgi/" (match-string 1) 1081 "?sm=Download")) 1082 (while (re-search-forward 1083 "type=hidden name=\"\\([^\"]+\\)\" value=\"\\([^\"]+\\)" 1084 nil t) 1085 (setq url (concat url "&" (match-string 1) "=" 1086 (match-string 2)))) 1087 (delete-region (point-min) (point-max)) 1088 (save-excursion 1089 (set-buffer (generate-new-buffer " *webmail-att*")) 1090 (mm-url-insert url) 1091 (push (current-buffer) webmail-buffer-list) 1092 (setq bufname (buffer-name))) 1093 (insert "<#part type=\"" type "\"") 1094 (if name (insert " filename=\"" name "\"")) 1095 (insert " buffer=\"" bufname "\"") 1096 (insert " disposition=inline><#/part>")))) 1097 (t 1098 (insert "<#part type=\"text/html\" disposition=inline>") 1099 (goto-char (point-max)) 1100 (insert "<#/part>"))))) 1101 1102(defun webmail-my-deja-article (file id) 1103 (let (base) 1104 (goto-char (point-min)) 1105 (unless (string-match "\\([^\"]+\\)/mail" webmail-aux) 1106 (webmail-error "article@0")) 1107 (setq base (match-string 1 webmail-aux)) 1108 (when (re-search-forward 1109 "href=\"[^\"]*\\(mailnf\\.[^\"]+act=move[^\"]+mid=\\([^\"&]+\\)[^\"]+\\)\"" 1110 nil t) 1111 (setq webmail-aux (concat base "/" (match-string 1))) 1112 (string-match "mid=[^\"&]+" webmail-aux) 1113 (setq webmail-aux (replace-match "mid=%s" nil nil webmail-aux))) 1114 (unless (search-forward "<HR noshade>" nil t) 1115 (webmail-error "article@1")) 1116 (delete-region (point-min) (point)) 1117 (unless (search-forward "<HR noshade>" nil t) 1118 (webmail-error "article@2")) 1119 (save-restriction 1120 (narrow-to-region (point-min) (point)) 1121 (while (search-forward "\r\n" nil t) 1122 (replace-match "\n")) 1123 (mm-url-remove-markup) 1124 (mm-url-decode-entities-nbsp) 1125 (goto-char (point-min)) 1126 (while (re-search-forward "\n\n+" nil t) 1127 (replace-match "\n")) 1128 (goto-char (point-max))) 1129 (save-restriction 1130 (narrow-to-region (point) (point-max)) 1131 (goto-char (point-max)) 1132 (unless (search-backward "<HR noshade>" nil t) 1133 (webmail-error "article@3")) 1134 (unless (search-backward "</TT>" nil t) 1135 (webmail-error "article@4")) 1136 (delete-region (point) (point-max)) 1137 (goto-char (point-min)) 1138 (while (not (eobp)) 1139 (webmail-my-deja-article-part base)) 1140 (insert "MIME-Version: 1.0\n" 1141 (prog1 1142 (mml-generate-mime) 1143 (delete-region (point-min) (point-max))))) 1144 (goto-char (point-min)) 1145 (insert "\n\nFrom nobody " (current-time-string) "\n") 1146 (insert "X-Gnus-Webmail: " (symbol-value 'user) 1147 "@" (symbol-name webmail-type) "\n") 1148 (if (eq (char-after) ?\n) 1149 (delete-char 1)) 1150 (mm-append-to-file (point-min) (point-max) file))) 1151 1152(provide 'webmail) 1153 1154;;; arch-tag: f75a4558-a8f6-46ec-b1c3-7a6434b3dd71 1155;;; webmail.el ends here 1156