← Back to branch summary

~ubuntu-branches/ubuntu/saucy/wl/saucy-proposed

« back to all changes in this revision

Viewing changes to .pc/10_elmo-intern-soft.patch/elmo/elmo-archive.el

  • Committer: Bazaar Package Importer
  • Author(s): Tatsuya Kinoshita
  • Date: 2010-06-20 21:35:01 UTC
  • Revision ID: james.westby@ubuntu.com-20100620213501-obb1ksb87poo8yrj
Tags: 2.14.0-12
http://bugs.debian.org/294658
* debian/emacsen-startup.in: Set ssl-program-name and ssl-program-arguments
  to use gnutls-cli instead of openssl s_client. (closes: #294658)
* debian/README.Debian.in: Add information to customize gnutls-cli options.
* debian/control: Add gnutls-bin to Suggests.
* debian/patches/20_ssl-cert-info.patch: Use "opsnssl" instead of
  ssl-program-name for ssl-certificate-information.
* debian/patches/10_elmo-intern-soft.patch: Define elmo-intern-soft to fix
  unknown archiver type.  Patch from [wl:14407] on 2010-03-02 by Katsuyoshi
  Ohara.
* debian/patches/0*.patch: Generated from applied patches.
* Switch to dpkg-source 3.0 (quilt) format.

Show diffs side-by-side

added added

removed removed

Lines of Context:
.pc/10_elmo-intern-soft.patch/elmo/elmo-archive.el
 
1
;;; elmo-archive.el --- Archive folder of ELMO. -*- coding: euc-japan -*-
 
2
 
 
3
;; Copyright (C) 1998,1999,2000 OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
 
4
;; Copyright (C) 1998,1999,2000 Yuuichi Teranishi <teranisi@gohome.org>
 
5
 
 
6
;; Author: OKUNISHI Fujikazu <fuji0924@mbox.kyoto-inet.or.jp>
 
7
;;      Yuuichi Teranishi <teranisi@gohome.org>
 
8
;; Keywords: mail, net news
 
9
;; Created: Sep 13, 1998
 
10
 
 
11
;; This file is part of ELMO (Elisp Library for Message Orchestration).
 
12
 
 
13
;; This program is free software; you can redistribute it and/or modify
 
14
;; it under the terms of the GNU General Public License as published by
 
15
;; the Free Software Foundation; either version 2, or (at your option)
 
16
;; any later version.
 
17
;;
 
18
;; This program is distributed in the hope that it will be useful,
 
19
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
 
20
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
21
;; GNU General Public License for more details.
 
22
;;
 
23
;; You should have received a copy of the GNU General Public License
 
24
;; along with GNU Emacs; see the file COPYING.  If not, write to the
 
25
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
 
26
;; Boston, MA 02111-1307, USA.
 
27
;;
 
28
 
 
29
;;; Commentary:
 
30
;;
 
31
;; TODO:
 
32
;; Info-Zip ���ѥ���������Ȥ��Ѥ������ܸ측����OS/2 ���ѡˡ�
 
33
 
 
34
;;; Code:
 
35
;;
 
36
(eval-when-compile (require 'cl))
 
37
 
 
38
(require 'elmo)
 
39
(require 'elmo-msgdb)
 
40
(require 'emu)
 
41
(require 'std11)
 
42
(eval-when-compile (require 'elmo-localdir))
 
43
 
 
44
;;; User vars.
 
45
(defvar elmo-archive-lha-dos-compatible
 
46
  (memq system-type '(OS/2 emx windows-nt))
 
47
  "*If non-nil, regard your LHA as compatible to DOS version.")
 
48
 
 
49
(defvar elmo-archive-use-izip-agent (memq system-type '(OS/2 emx))
 
50
  "*If non-nil, use the special agent in fetching headers.")
 
51
 
 
52
(defvar elmo-archive-folder-path "~/Mail"
 
53
  "*Base directory for archive folders.")
 
54
 
 
55
(defvar elmo-archive-basename "elmo-archive"
 
56
  "*Common basename of archive folder file, w/o suffix.")
 
57
 
 
58
(defvar elmo-archive-cmdstr-max-length 8000 ; SASAKI Osamu's suggestion
 
59
  "*Command line string limitation under OS/2, exactly 8190 bytes.")
 
60
 
 
61
(defvar elmo-archive-fetch-headers-volume 50
 
62
  "*Quantity of article headers to fetch per once.")
 
63
 
 
64
(defvar elmo-archive-dummy-file ".elmo-archive"
 
65
  "*Name of dummy file that will be appended when the folder is null.")
 
66
 
 
67
(defvar elmo-archive-check-existance-strict t
 
68
  "*Check existance of archive contents if non-nil.")
 
69
 
 
70
(defvar elmo-archive-load-hook nil
 
71
  "*Hook called after loading elmo-archive.el.")
 
72
 
 
73
(defvar elmo-archive-treat-file nil
 
74
  "*Treat archive folder as a file if non-nil.")
 
75
 
 
76
;;; User variables for elmo-archive.
 
77
(defvar elmo-archive-default-type 'zip
 
78
  "*Default archiver type.  The value must be a symbol.")
 
79
 
 
80
(defvar elmo-archive-use-cache nil
 
81
  "Use cache in archive folder.")
 
82
 
 
83
;;; ELMO Local directory folder
 
84
(eval-and-compile
 
85
  (luna-define-class elmo-archive-folder (elmo-folder)
 
86
                     (archive-name archive-type archive-prefix dir-name))
 
87
  (luna-define-internal-accessors 'elmo-archive-folder))
 
88
 
 
89
(luna-define-generic elmo-archive-folder-path (folder)
 
90
  "Return local directory path of the FOLDER.")
 
91
 
 
92
(luna-define-method elmo-archive-folder-path ((folder elmo-archive-folder))
 
93
  elmo-archive-folder-path)
 
94
 
 
95
(luna-define-method elmo-folder-initialize ((folder
 
96
                                             elmo-archive-folder)
 
97
                                            name)
 
98
  (elmo-archive-folder-set-dir-name-internal folder name)
 
99
  (when (string-match
 
100
         "^\\([^;]*\\);?\\([^;]*\\);?\\([^;]*\\)$"
 
101
         name)
 
102
    ;; Drive letter is OK!
 
103
    (or (elmo-archive-folder-set-archive-name-internal
 
104
         folder (elmo-match-string 1 name))
 
105
        (elmo-archive-folder-set-archive-name-internal
 
106
         folder ""))
 
107
    (or (elmo-archive-folder-set-archive-type-internal
 
108
         folder (intern-soft (elmo-match-string 2 name)))
 
109
        (elmo-archive-folder-set-archive-type-internal
 
110
         folder elmo-archive-default-type))
 
111
    (or (elmo-archive-folder-set-archive-prefix-internal
 
112
         folder (elmo-match-string 3 name))
 
113
        (elmo-archive-folder-set-archive-prefix-internal
 
114
         folder "")))
 
115
  folder)
 
116
 
 
117
(luna-define-method elmo-folder-expand-msgdb-path ((folder
 
118
                                                    elmo-archive-folder))
 
119
  ;; For compatibility
 
120
  (expand-file-name
 
121
   (elmo-replace-string-as-filename
 
122
    (elmo-folder-name-internal folder))
 
123
   (expand-file-name (concat (symbol-name (elmo-folder-type-internal folder))
 
124
                             "/"
 
125
                             (symbol-name
 
126
                              (elmo-archive-folder-archive-type-internal
 
127
                               folder)))
 
128
                     elmo-msgdb-directory)))
 
129
 
 
130
;;; MMDF parser -- info-zip agent w/ REXX
 
131
(defvar elmo-mmdf-delimiter "^\01\01\01\01$"
 
132
  "*Regular expression of MMDF delimiter.")
 
133
 
 
134
(defvar elmo-unixmail-delimiter "^From \\([^ \t]+\\) \\(.+\\)"
 
135
  "*Regular expression of UNIX Mail delimiter.")
 
136
 
 
137
(defvar elmo-archive-header-regexp "^[ \t]*[-=][-=][-=][-=]"
 
138
  "*Common regexp of the delimiter in listing archive.") ; marche
 
139
 
 
140
(defvar elmo-archive-file-regexp-alist
 
141
  (append
 
142
   (if elmo-archive-lha-dos-compatible
 
143
       '((lha . "^%s\\([0-9]+\\)$"))    ; OS/2,DOS w/  "-x"
 
144
     '((lha . "^.*[ \t]%s\\([0-9]+\\)$")))
 
145
   '((zip . "^.*[ \t]%s\\([0-9]+\\)$")
 
146
     (zoo . "^.*[ \t]%s\\([0-9]+\\)$")
 
147
     (tar . "^%s\\([0-9]+\\)$")         ; ok
 
148
     (tgz . "^%s\\([0-9]+\\)$")         ; ok
 
149
     (rar . "^[ \t]%s\\([0-9]+\\)$"))))
 
150
 
 
151
(defvar elmo-archive-suffix-alist
 
152
   '((lha . ".lzh")  ; default
 
153
;;;  (lha . ".lzs")
 
154
     (zip . ".zip")
 
155
     (zoo . ".zoo")
 
156
;;;  (arc . ".arc")
 
157
;;;  (arj . ".arj")
 
158
     (rar . ".rar")
 
159
     (tar . ".tar")
 
160
     (tgz . ".tar.gz")))
 
161
 
 
162
;;; lha
 
163
(defvar elmo-archive-lha-method-alist
 
164
  (if elmo-archive-lha-dos-compatible
 
165
      ;; OS/2
 
166
      '((cp  . ("lha" "u" "-x"))
 
167
        (mv  . ("lha" "m" "-x"))
 
168
        (rm  . ("lha" "d"))
 
169
        (ls  . ("lha" "l" "-x"))
 
170
        (cat . ("lha" "p" "-n"))
 
171
        (ext . ("lha" "x"))             ; "-x"
 
172
        )
 
173
    ;; some UN|X
 
174
    '((cp  . ("lha" "u"))
 
175
      (mv  . ("lha" "m"))
 
176
      (rm  . ("lha" "d"))
 
177
      (ls  . ("lha" "l"))
 
178
      (cat . ("lha" "pq"))
 
179
      (ext . ("lha" "x")))))
 
180
 
 
181
;;; info-zip/unzip
 
182
(defvar elmo-archive-zip-method-alist
 
183
  '((cp       . ("zip" "-9q"))
 
184
    (cp-pipe  . ("zip" "-9q@"))
 
185
    (mv       . ("zip" "-mDq9"))
 
186
    (mv-pipe  . ("zip" "-mDq9@"))
 
187
    (rm       . ("zip" "-dq"))
 
188
    (rm-pipe  . ("zip" "-dq@"))
 
189
    (ls       . ("unzip" "-lq"))
 
190
    (cat      . ("unzip" "-pq"))
 
191
    (ext      . ("unzip"))
 
192
    (cat-headers . ("izwlagent" "--cat"))))
 
193
 
 
194
;;; zoo
 
195
(defvar elmo-archive-zoo-method-alist
 
196
  '((cp       . ("zoo" "aq"))
 
197
    (cp-pipe  . ("zoo" "aqI"))
 
198
    (mv       . ("zoo" "aMq"))
 
199
    (mv-pipe  . ("zoo" "aMqI"))
 
200
    (rm       . ("zoo" "Dq"))
 
201
    (ls       . ("zoo" "l"))            ; normal
 
202
    (cat      . ("zoo" "xpq"))
 
203
    (ext      . ("zoo" "xq"))))
 
204
 
 
205
;;; rar
 
206
(defvar elmo-archive-rar-method-alist
 
207
  '((cp       . ("rar" "u" "-m5"))
 
208
    (mv       . ("rar" "m" "-m5"))
 
209
    (rm       . ("rar" "d"))
 
210
    (ls       . ("rar" "v"))
 
211
    (cat      . ("rar" "p" "-inul"))
 
212
    (ext      . ("rar" "x"))))
 
213
 
 
214
;;; GNU tar (*.tar)
 
215
(defvar elmo-archive-tar-method-alist
 
216
  (if elmo-archive-lha-dos-compatible
 
217
      '((ls   . ("gtar" "-tf"))
 
218
        (cat  . ("gtar" "--posix Oxf"))
 
219
        (ext  . ("gtar" "-xf"))
 
220
;;;     (rm   . ("gtar" "--posix" "--delete" "-f")) ; well not work
 
221
        )
 
222
    '((ls    . ("gtar" "-tf"))
 
223
      (cat   . ("gtar" "-Oxf"))
 
224
      (ext   . ("gtar" "-xf"))
 
225
;;;     (rm    . ("gtar" "--delete" "-f")) ;; well not work
 
226
      )))
 
227
 
 
228
;;; GNU tar (*.tar.gz, *.tar.Z, *.tar.bz2)
 
229
(defvar elmo-archive-tgz-method-alist
 
230
  '((ls         . ("gtar" "-ztf"))
 
231
    (cat        . ("gtar" "-Ozxf"))
 
232
    (create     . ("gtar" "-zcf"))
 
233
;;; (rm         . elmo-archive-tgz-rm-func)
 
234
    (cp         . elmo-archive-tgz-cp-func)
 
235
    (mv         . elmo-archive-tgz-mv-func)
 
236
    (ext        . ("gtar" "-zxf"))
 
237
    ;; tgz special method
 
238
    (decompress . ("gzip" "-d"))
 
239
    (compress   . ("gzip"))
 
240
    (append     . ("gtar" "-uf"))
 
241
;;; (delete     . ("gtar" "--delete" "-f")) ; well not work
 
242
    ))
 
243
 
 
244
(defvar elmo-archive-method-list
 
245
  '(elmo-archive-lha-method-alist
 
246
    elmo-archive-zip-method-alist
 
247
    elmo-archive-zoo-method-alist
 
248
;;; elmo-archive-tar-method-alist
 
249
    elmo-archive-tgz-method-alist
 
250
;;; elmo-archive-arc-method-alist
 
251
;;; elmo-archive-arj-method-alist
 
252
    elmo-archive-rar-method-alist))
 
253
 
 
254
;;; Internal vars.
 
255
(defvar elmo-archive-method-alist nil)
 
256
(defvar elmo-archive-suffixes nil)
 
257
 
 
258
 
 
259
;;; Macro
 
260
(defmacro elmo-archive-get-method (type action)
 
261
  (` (cdr (assq (, action) (cdr (assq (, type)
 
262
                                      elmo-archive-method-alist))))))
 
263
 
 
264
(defmacro elmo-archive-get-suffix (type)
 
265
  (` (cdr (assq (, type)
 
266
                elmo-archive-suffix-alist))))
 
267
 
 
268
(defmacro elmo-archive-get-regexp (type)
 
269
  (` (cdr (assq (, type)
 
270
                elmo-archive-file-regexp-alist))))
 
271
 
 
272
(defsubst elmo-archive-call-process (prog args &optional output)
 
273
  (= (apply 'call-process prog nil output nil args) 0))
 
274
 
 
275
(defsubst elmo-archive-call-method (method args &optional output)
 
276
  (cond
 
277
   ((functionp method)
 
278
    (funcall method args output))
 
279
   (t
 
280
    (elmo-archive-call-process
 
281
     (car method) (append (cdr method) args) output))))
 
282
 
 
283
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
284
;;; Scan Folder
 
285
 
 
286
(defsubst elmo-archive-list-folder-subr (folder &optional nonsort)
 
287
  "*Returns list of number-file(int, not string) in archive FILE.
 
288
TYPE specifies the archiver's symbol."
 
289
  (let* ((type (elmo-archive-folder-archive-type-internal folder))
 
290
         (prefix (elmo-archive-folder-archive-prefix-internal folder))
 
291
         (file (elmo-archive-get-archive-name folder))
 
292
         (method (elmo-archive-get-method type 'ls))
 
293
         (args (list file))
 
294
         (file-regexp (format (elmo-archive-get-regexp type)
 
295
                              (elmo-concat-path (regexp-quote prefix) "")))
 
296
         (killed (elmo-folder-killed-list-internal folder))
 
297
         numbers buf file-list header-end)
 
298
    (if (file-exists-p file)
 
299
        (with-temp-buffer
 
300
          (unless (elmo-archive-call-method method args t)
 
301
            (error "%s exited abnormally!" method))
 
302
          (goto-char (point-min))
 
303
          (when (re-search-forward elmo-archive-header-regexp nil t)
 
304
            (forward-line 1)
 
305
            (setq header-end (point))
 
306
            (when (re-search-forward elmo-archive-header-regexp nil t)
 
307
              (beginning-of-line)
 
308
              (narrow-to-region header-end (point))
 
309
              (goto-char (point-min))))
 
310
          (while (and (re-search-forward file-regexp nil t)
 
311
                      (not (eobp)))  ; for GNU tar 981010
 
312
            (setq file-list (nconc file-list (list (string-to-int
 
313
                                                    (match-string 1)))))))
 
314
      (error "%s does not exist" file))
 
315
    (if nonsort
 
316
        (cons (or (elmo-max-of-list file-list) 0)
 
317
              (if killed
 
318
                  (- (length file-list)
 
319
                     (elmo-msgdb-killed-list-length killed))
 
320
                (length file-list)))
 
321
      (setq numbers (sort file-list '<))
 
322
      (elmo-living-messages numbers killed))))
 
323
 
 
324
(luna-define-method elmo-folder-list-messages-internal ((folder
 
325
                                                         elmo-archive-folder)
 
326
                                                        &optional nohide)
 
327
  (elmo-archive-list-folder-subr folder))
 
328
 
 
329
(luna-define-method elmo-folder-status ((folder elmo-archive-folder))
 
330
  (elmo-archive-list-folder-subr folder t))
 
331
 
 
332
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
333
;;; Folder related functions
 
334
 
 
335
(defsubst elmo-archive-get-archive-directory (folder)
 
336
  ;; allow fullpath. return format is "/foo/bar/".
 
337
  (if (file-name-absolute-p (elmo-archive-folder-archive-name-internal folder))
 
338
      (if (find-file-name-handler
 
339
           (elmo-archive-folder-archive-name-internal folder)
 
340
           'copy-file)
 
341
          (elmo-archive-folder-archive-name-internal folder)
 
342
        (expand-file-name (elmo-archive-folder-archive-name-internal folder)))
 
343
    (expand-file-name (elmo-archive-folder-archive-name-internal folder)
 
344
                      elmo-archive-folder-path)))
 
345
 
 
346
(defun elmo-archive-get-archive-name (folder)
 
347
  (let ((dir (elmo-archive-get-archive-directory folder))
 
348
        (suffix (elmo-archive-get-suffix
 
349
                 (elmo-archive-folder-archive-type-internal
 
350
                  folder)))
 
351
        filename dbdir)
 
352
    (unless suffix
 
353
      (error "Unknown archiver type: %s"
 
354
             (elmo-archive-folder-archive-type-internal folder)))
 
355
    (if elmo-archive-treat-file
 
356
        (if (string-match (concat (regexp-quote suffix) "$")
 
357
                          (elmo-archive-folder-archive-name-internal folder))
 
358
            (expand-file-name (elmo-archive-folder-archive-name-internal
 
359
                               folder)
 
360
                              elmo-archive-folder-path)
 
361
          (expand-file-name (concat (elmo-archive-folder-archive-name-internal
 
362
                                     folder)
 
363
                                    suffix)
 
364
                            elmo-archive-folder-path))
 
365
      (if (string-match
 
366
           "^\\(ange-ftp\\|efs\\)-"
 
367
           (symbol-name (find-file-name-handler dir 'copy-file)))
 
368
          ;; ange-ftp, efs
 
369
          (progn
 
370
            (setq filename (expand-file-name
 
371
                            (concat elmo-archive-basename suffix)
 
372
                            (setq dbdir
 
373
                                  (elmo-folder-msgdb-path folder))))
 
374
            (if (file-directory-p dbdir)
 
375
                (); ok.
 
376
              (if (file-exists-p dbdir)
 
377
                  (error "File %s already exists" dbdir)
 
378
                (elmo-make-directory dbdir)))
 
379
            (if (not (file-exists-p filename))
 
380
                (copy-file
 
381
                 (if (file-directory-p dir)
 
382
                     (expand-file-name
 
383
                      (concat elmo-archive-basename suffix)
 
384
                      dir)
 
385
                   dir)
 
386
                 filename))
 
387
            filename)
 
388
        (if (or (not (file-exists-p dir))
 
389
                (file-directory-p dir))
 
390
            (expand-file-name
 
391
             (concat elmo-archive-basename suffix)
 
392
             dir)
 
393
          dir)))))
 
394
 
 
395
(luna-define-method elmo-folder-exists-p ((folder elmo-archive-folder))
 
396
  (file-exists-p (elmo-archive-get-archive-name folder)))
 
397
 
 
398
(luna-define-method elmo-folder-creatable-p ((folder elmo-archive-folder))
 
399
  t)
 
400
 
 
401
(luna-define-method elmo-folder-writable-p ((folder elmo-archive-folder))
 
402
  t)
 
403
 
 
404
(luna-define-method elmo-folder-create ((folder elmo-archive-folder))
 
405
  (let* ((dir (directory-file-name      ; remove tail slash.
 
406
               (elmo-archive-get-archive-directory folder)))
 
407
         (type (elmo-archive-folder-archive-type-internal folder))
 
408
         (arc (elmo-archive-get-archive-name folder)))
 
409
    (if elmo-archive-treat-file
 
410
        (setq dir (directory-file-name (file-name-directory dir))))
 
411
    (cond ((and (file-exists-p dir)
 
412
                (not (file-directory-p dir)))
 
413
           ;; file exists
 
414
           (error "Create folder failed; File \"%s\" exists" dir))
 
415
          ((file-directory-p dir)
 
416
           (if (file-exists-p arc)
 
417
               t                        ; return value
 
418
             (elmo-archive-create-file arc type folder)))
 
419
          (t
 
420
           (elmo-make-directory dir)
 
421
           (elmo-archive-create-file arc type folder)
 
422
           t))))
 
423
 
 
424
(defun elmo-archive-create-file (archive type folder)
 
425
  (save-excursion
 
426
    (let* ((tmp-dir (directory-file-name
 
427
                     (elmo-folder-msgdb-path folder)))
 
428
           (dummy elmo-archive-dummy-file)
 
429
           (method (or (elmo-archive-get-method type 'create)
 
430
                       (elmo-archive-get-method type 'mv)))
 
431
           (args (list archive dummy)))
 
432
      (when (null method)
 
433
        (ding)
 
434
        (error "WARNING: read-only mode: %s (method undefined)" type))
 
435
      (cond
 
436
       ((file-directory-p tmp-dir)
 
437
        ()) ;nop
 
438
       ((file-exists-p tmp-dir)
 
439
        ;; file exists
 
440
        (error "Create directory failed; File \"%s\" exists" tmp-dir))
 
441
       (t
 
442
        (elmo-make-directory tmp-dir)))
 
443
      (elmo-bind-directory
 
444
       tmp-dir
 
445
       (write-region (point) (point) dummy nil 'no-msg)
 
446
       (prog1
 
447
           (elmo-archive-call-method method args)
 
448
         (if (file-exists-p dummy)
 
449
             (delete-file dummy)))
 
450
       ))))
 
451
 
 
452
(luna-define-method elmo-folder-delete ((folder elmo-archive-folder))
 
453
  (let ((msgs (and (elmo-folder-exists-p folder)
 
454
                   (elmo-folder-list-messages folder))))
 
455
    (when (yes-or-no-p (format "%sDelete msgdb and substance of \"%s\"? "
 
456
                               (if (> (length msgs) 0)
 
457
                                   (format "%d msg(s) exists. " (length msgs))
 
458
                                 "")
 
459
                               (elmo-folder-name-internal folder)))
 
460
      (let ((arc (elmo-archive-get-archive-name folder)))
 
461
        (if (not (file-exists-p arc))
 
462
            (error "No such file: %s" arc)
 
463
          (delete-file arc))
 
464
        (elmo-msgdb-delete-path folder)
 
465
        t))))
 
466
 
 
467
(luna-define-method elmo-folder-rename-internal ((folder elmo-archive-folder)
 
468
                                                 new-folder)
 
469
  (let* ((old-arc (elmo-archive-get-archive-name folder))
 
470
         (new-arc (elmo-archive-get-archive-name new-folder))
 
471
         (new-dir (directory-file-name
 
472
                   (elmo-archive-get-archive-directory new-folder))))
 
473
    (if elmo-archive-treat-file
 
474
        (setq new-dir (directory-file-name (file-name-directory new-dir))))
 
475
    (unless (and (eq (elmo-archive-folder-archive-type-internal folder)
 
476
                     (elmo-archive-folder-archive-type-internal new-folder))
 
477
                 (equal (elmo-archive-folder-archive-prefix-internal
 
478
                         folder)
 
479
                        (elmo-archive-folder-archive-prefix-internal
 
480
                         new-folder)))
 
481
      (error "Not same archive type and prefix"))
 
482
    (unless (file-exists-p old-arc)
 
483
      (error "No such file: %s" old-arc))
 
484
    (when (file-exists-p new-arc)
 
485
      (error "Already exists: %s" new-arc))
 
486
    (unless (file-directory-p new-dir)
 
487
      (elmo-make-directory new-dir))
 
488
    (rename-file old-arc new-arc)
 
489
    t))
 
490
 
 
491
(defun elmo-archive-folder-list-subfolders (folder one-level)
 
492
  (if elmo-archive-treat-file
 
493
      (let* ((path (elmo-archive-get-archive-directory folder))
 
494
             (base-folder (or (elmo-archive-folder-archive-name-internal
 
495
                               folder)
 
496
                              ""))
 
497
             (suffix (elmo-archive-folder-archive-type-internal folder))
 
498
             (prefix (if (string=
 
499
                          (elmo-archive-folder-archive-prefix-internal folder)
 
500
                          "")
 
501
                         ""
 
502
                       (concat ";"
 
503
                               (elmo-archive-folder-archive-prefix-internal
 
504
                                folder))))
 
505
             (dir (if (file-directory-p path)
 
506
                      path (file-name-directory path)))
 
507
             (name (if (file-directory-p path)
 
508
                       "" (file-name-nondirectory path)))
 
509
             (flist (and (file-directory-p dir)
 
510
                         (directory-files dir nil
 
511
                                          (if (> (length name) 0)
 
512
                                              (concat "^" name "[^A-z][^A-z]")
 
513
                                            name)
 
514
                                          nil)))
 
515
             (regexp (format "^\\(.*\\)\\(%s\\)$"
 
516
                             (mapconcat
 
517
                              '(lambda (x) (regexp-quote (cdr x)))
 
518
                              elmo-archive-suffix-alist
 
519
                              "\\|"))))
 
520
        (if (string-match "\\(.*\\)/$" base-folder) ; ends with '/'.
 
521
            (setq base-folder (elmo-match-string 1 base-folder))
 
522
          (unless (file-directory-p path)
 
523
            (setq base-folder (or (file-name-directory base-folder) ""))))
 
524
        (delq
 
525
         nil
 
526
         (mapcar
 
527
          '(lambda (x)
 
528
             (when (and (string-match regexp x)
 
529
                        (eq suffix
 
530
                            (car
 
531
                             (rassoc (elmo-match-string 2 x)
 
532
                                     elmo-archive-suffix-alist))))
 
533
               (format "%s%s;%s%s"
 
534
                       (elmo-folder-prefix-internal folder)
 
535
                       (elmo-concat-path base-folder (elmo-match-string 1 x))
 
536
                       suffix prefix)))
 
537
          flist)))
 
538
    (elmo-mapcar-list-of-list
 
539
     (function (lambda (x)
 
540
                 (if (file-exists-p
 
541
                      (expand-file-name
 
542
                       (concat elmo-archive-basename
 
543
                               (elmo-archive-get-suffix
 
544
                                (elmo-archive-folder-archive-type-internal
 
545
                                 folder)))
 
546
                       (expand-file-name
 
547
                        x
 
548
                        (elmo-archive-folder-path folder))))
 
549
                     (concat (elmo-folder-prefix-internal folder) x))))
 
550
     (elmo-list-subdirectories
 
551
      (elmo-archive-folder-path folder)
 
552
      (or (elmo-archive-folder-dir-name-internal folder) "")
 
553
      one-level))))
 
554
 
 
555
(luna-define-method elmo-folder-list-subfolders ((folder elmo-archive-folder)
 
556
                                                 &optional one-level)
 
557
  (elmo-archive-folder-list-subfolders folder one-level))
 
558
 
 
559
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
560
;;; Article file related functions
 
561
;;; read(extract) / append(move) / delete(delete) / query(list)
 
562
 
 
563
(defsubst elmo-archive-message-fetch-internal (folder number)
 
564
  (let* ((type (elmo-archive-folder-archive-type-internal folder))
 
565
         (arc (elmo-archive-get-archive-name folder))
 
566
         (prefix (elmo-archive-folder-archive-prefix-internal folder))
 
567
         (method (elmo-archive-get-method type 'cat))
 
568
         (args (list arc (elmo-concat-path
 
569
                          prefix (int-to-string number)))))
 
570
    (and (file-exists-p arc)
 
571
         (as-binary-process
 
572
          (elmo-archive-call-method method args t))
 
573
         (progn
 
574
           (elmo-delete-cr-buffer)
 
575
           t))))
 
576
 
 
577
(luna-define-method elmo-message-fetch-internal ((folder elmo-archive-folder)
 
578
                                                 number strategy
 
579
                                                 &optional section unseen)
 
580
  (elmo-archive-message-fetch-internal folder number))
 
581
 
 
582
(luna-define-method elmo-folder-append-buffer ((folder elmo-archive-folder)
 
583
                                               &optional flags number)
 
584
  (elmo-archive-folder-append-buffer folder flags number))
 
585
 
 
586
;; verrrrrry slow!!
 
587
(defun elmo-archive-folder-append-buffer (folder flags number)
 
588
  (let* ((type (elmo-archive-folder-archive-type-internal folder))
 
589
         (prefix (elmo-archive-folder-archive-prefix-internal folder))
 
590
         (arc (elmo-archive-get-archive-name folder))
 
591
         (method (elmo-archive-get-method type 'mv))
 
592
         (next-num (or number
 
593
                       (1+ (if (file-exists-p arc)
 
594
                               (car
 
595
                                (elmo-folder-status folder)) 0))))
 
596
         (tmp-dir (elmo-folder-msgdb-path folder))
 
597
         (src-buffer (current-buffer))
 
598
         dst-buffer
 
599
         newfile)
 
600
    (when (null method)
 
601
      (ding)
 
602
      (error "WARNING: read-only mode: %s (method undefined)" type))
 
603
    (with-temp-buffer
 
604
      (let ((tmp-dir (expand-file-name prefix tmp-dir)))
 
605
        (when (not (file-directory-p tmp-dir))
 
606
          (elmo-make-directory (directory-file-name tmp-dir))))
 
607
      (setq newfile (elmo-concat-path
 
608
                     prefix
 
609
                     (int-to-string next-num)))
 
610
      (unwind-protect
 
611
          (elmo-bind-directory
 
612
           tmp-dir
 
613
           (if (and (or (functionp method) (car method))
 
614
                    (file-writable-p newfile))
 
615
               (progn
 
616
                 (setq dst-buffer (current-buffer))
 
617
                 (with-current-buffer src-buffer
 
618
                   (copy-to-buffer dst-buffer (point-min) (point-max)))
 
619
                 (as-binary-output-file
 
620
                  (write-region (point-min) (point-max) newfile nil 'no-msg))
 
621
                 (when (elmo-archive-call-method method (list arc newfile))
 
622
                   (elmo-folder-preserve-flags
 
623
                    folder
 
624
                    (with-current-buffer src-buffer
 
625
                      (elmo-msgdb-get-message-id-from-buffer))
 
626
                    flags)
 
627
                   t))
 
628
             nil))))))
 
629
 
 
630
(luna-define-method elmo-folder-append-messages :around
 
631
  ((folder elmo-archive-folder) src-folder numbers &optional same-number)
 
632
  (let ((prefix (elmo-archive-folder-archive-prefix-internal folder)))
 
633
    (cond
 
634
     ((and same-number
 
635
           (null prefix)
 
636
           (elmo-folder-message-file-p src-folder)
 
637
           (elmo-folder-message-file-number-p src-folder))
 
638
      ;; same-number(localdir, localnews) -> archive
 
639
      (unless (elmo-archive-append-files folder
 
640
                                         (elmo-folder-message-file-directory src-folder)
 
641
                                         numbers)
 
642
        (setq numbers nil))
 
643
      (elmo-progress-notify 'elmo-folder-move-messages (length numbers))
 
644
      numbers)
 
645
     ((elmo-folder-message-make-temp-file-p src-folder)
 
646
      ;; not-same-number (localdir, localnews), (archive maildir) -> archive
 
647
      (let ((temp-dir (elmo-folder-message-make-temp-files
 
648
                       src-folder
 
649
                       numbers
 
650
                       (unless same-number
 
651
                         (1+ (if (file-exists-p (elmo-archive-get-archive-name
 
652
                                                 folder))
 
653
                                 (car (elmo-folder-status folder)) 0)))))
 
654
            new-dir base-dir files)
 
655
        (setq base-dir temp-dir)
 
656
        (when (> (length prefix) 0)
 
657
          (when (file-name-directory prefix)
 
658
            (elmo-make-directory (file-name-directory prefix)))
 
659
          (rename-file
 
660
           temp-dir
 
661
           (setq new-dir
 
662
                 (expand-file-name
 
663
                  prefix
 
664
                  ;; parent of temp-dir..(works in windows?)
 
665
                  (expand-file-name ".." temp-dir))))
 
666
          ;; now temp-dir has name prefix.
 
667
          (setq temp-dir new-dir)
 
668
          ;; parent of prefix becomes base-dir.
 
669
          (setq base-dir (expand-file-name ".." temp-dir)))
 
670
        (setq files
 
671
              (mapcar
 
672
               '(lambda (x) (elmo-concat-path prefix x))
 
673
               (directory-files temp-dir nil "^[^\\.]")))
 
674
        (if (elmo-archive-append-files folder
 
675
                                       base-dir
 
676
                                       files)
 
677
            (elmo-delete-directory temp-dir)
 
678
          (setq numbers nil)))
 
679
      (elmo-progress-notify 'elmo-folder-move-messages (length numbers))
 
680
      numbers)
 
681
     (t (luna-call-next-method)))))
 
682
 
 
683
(luna-define-method elmo-folder-message-make-temp-file-p
 
684
  ((folder elmo-archive-folder))
 
685
  (let ((type (elmo-archive-folder-archive-type-internal folder)))
 
686
    (or (elmo-archive-get-method type 'ext-pipe)
 
687
        (elmo-archive-get-method type 'ext))))
 
688
 
 
689
(luna-define-method elmo-folder-message-make-temp-files
 
690
  ((folder elmo-archive-folder) numbers
 
691
   &optional start-number)
 
692
  (elmo-archive-folder-message-make-temp-files folder numbers start-number))
 
693
 
 
694
(defun elmo-archive-folder-message-make-temp-files (folder
 
695
                                                    numbers
 
696
                                                    start-number)
 
697
  (let* ((tmp-dir-src (elmo-folder-make-temporary-directory folder))
 
698
         (tmp-dir-dst (elmo-folder-make-temporary-directory folder))
 
699
         (arc     (elmo-archive-get-archive-name folder))
 
700
         (type    (elmo-archive-folder-archive-type-internal folder))
 
701
         (prefix  (elmo-archive-folder-archive-prefix-internal folder))
 
702
         (p-method (elmo-archive-get-method type 'ext-pipe))
 
703
         (n-method (elmo-archive-get-method type 'ext))
 
704
         (tmp-msgs (mapcar (lambda (x) (elmo-concat-path
 
705
                                        prefix
 
706
                                        (int-to-string x))) numbers))
 
707
         number)
 
708
    ;; Expand files in the tmp-dir-src.
 
709
    (elmo-bind-directory
 
710
     tmp-dir-src
 
711
     (cond
 
712
      ((functionp n-method)
 
713
       (funcall n-method (cons arc tmp-msgs)))
 
714
      (p-method
 
715
       (let ((p-prog (car p-method))
 
716
             (p-prog-arg (cdr p-method)))
 
717
         (elmo-archive-exec-msgs-subr1
 
718
          p-prog (append p-prog-arg (list arc)) tmp-msgs)))
 
719
      (t
 
720
       (let ((n-prog (car n-method))
 
721
             (n-prog-arg (cdr n-method)))
 
722
         (elmo-archive-exec-msgs-subr2
 
723
          n-prog (append n-prog-arg (list arc)) tmp-msgs
 
724
          (length arc))))))
 
725
    ;; Move files to the tmp-dir-dst.
 
726
    (setq number start-number)
 
727
    (dolist (tmp-file tmp-msgs)
 
728
      (rename-file (expand-file-name
 
729
                    tmp-file
 
730
                    tmp-dir-src)
 
731
                   (expand-file-name
 
732
                    (if start-number
 
733
                        (int-to-string number)
 
734
                      (file-name-nondirectory tmp-file))
 
735
                    tmp-dir-dst))
 
736
      (if start-number (incf number)))
 
737
    ;; Remove tmp-dir-src.
 
738
    (elmo-delete-directory tmp-dir-src)
 
739
    ;; tmp-dir-dst is the return directory.
 
740
    tmp-dir-dst))
 
741
 
 
742
(defun elmo-archive-append-files (folder dir &optional files)
 
743
  (let* ((dst-type (elmo-archive-folder-archive-type-internal folder))
 
744
         (arc (elmo-archive-get-archive-name folder))
 
745
         (prefix (elmo-archive-folder-archive-prefix-internal folder))
 
746
         (p-method (elmo-archive-get-method dst-type 'cp-pipe))
 
747
         (n-method (elmo-archive-get-method dst-type 'cp))
 
748
         src tmp newfile)
 
749
    (unless (elmo-folder-exists-p folder) (elmo-folder-create folder))
 
750
    (unless files (setq files (directory-files dir nil "^[^\\.]")))
 
751
    (when (null (or p-method n-method))
 
752
      (ding)
 
753
      (error "WARNING: read-only mode: %s (method undefined)" dst-type))
 
754
    (save-excursion
 
755
      (elmo-bind-directory
 
756
       dir
 
757
       (cond
 
758
        ((functionp n-method)
 
759
         (funcall n-method (cons arc files)))
 
760
        (p-method
 
761
         (let ((p-prog (car p-method))
 
762
               (p-prog-arg (cdr p-method)))
 
763
           (elmo-archive-exec-msgs-subr1
 
764
            p-prog (append p-prog-arg (list arc)) files)))
 
765
        (t
 
766
         (let ((n-prog (car n-method))
 
767
               (n-prog-arg (cdr n-method)))
 
768
           (elmo-archive-exec-msgs-subr2
 
769
            n-prog (append n-prog-arg (list arc)) files (length arc)))))))))
 
770
 
 
771
(luna-define-method elmo-folder-delete-messages-internal ((folder
 
772
                                                           elmo-archive-folder)
 
773
                                                          numbers)
 
774
  (let* ((type (elmo-archive-folder-archive-type-internal folder))
 
775
         (prefix (elmo-archive-folder-archive-prefix-internal folder))
 
776
         (arc (elmo-archive-get-archive-name folder))
 
777
         (p-method (elmo-archive-get-method type 'rm-pipe))
 
778
         (n-method (elmo-archive-get-method type 'rm))
 
779
         (numbers (mapcar '(lambda (x) (elmo-concat-path
 
780
                                        prefix
 
781
                                        (int-to-string x)))
 
782
                          numbers)))
 
783
    (cond ((functionp n-method)
 
784
           (funcall n-method (cons arc numbers)))
 
785
          (p-method
 
786
           (let ((p-prog (car p-method))
 
787
                 (p-prog-arg (cdr p-method)))
 
788
             (elmo-archive-exec-msgs-subr1
 
789
              p-prog (append p-prog-arg (list arc)) numbers)))
 
790
          (n-method
 
791
           (let ((n-prog (car n-method))
 
792
                 (n-prog-arg (cdr n-method)))
 
793
             (elmo-archive-exec-msgs-subr2
 
794
              n-prog (append n-prog-arg (list arc)) numbers (length arc))))
 
795
          (t
 
796
           (ding)
 
797
           (error "WARNING: not delete: %s (method undefined)" type)))))
 
798
 
 
799
(defun elmo-archive-exec-msgs-subr1 (prog args msgs)
 
800
  (with-temp-buffer
 
801
    (insert (mapconcat 'concat msgs "\n")) ;string
 
802
    (= 0 (apply 'call-process-region (point-min) (point-max)
 
803
                prog nil nil nil args))))
 
804
 
 
805
(defun elmo-archive-exec-msgs-subr2 (prog args msgs arc-length)
 
806
  (let ((max-len (- elmo-archive-cmdstr-max-length arc-length))
 
807
        (n (length msgs))
 
808
        rest i sum)
 
809
    (setq rest msgs) ;string
 
810
    (setq i 1)
 
811
    (setq sum 0)
 
812
    (catch 'done
 
813
      (while (and rest (<= i n))
 
814
        (mapcar '(lambda (x)
 
815
                   (let* ((len (length x))
 
816
                          (files (member x (reverse rest))))
 
817
                     ;; total(previous) + current + white space
 
818
                     (if (<= max-len (+ sum len 1))
 
819
                         (progn
 
820
                           (unless
 
821
                               (elmo-archive-call-process
 
822
                                prog (append args files))
 
823
                             (throw 'done nil))
 
824
                           (setq sum 0) ;; reset
 
825
                           (setq rest (nthcdr i rest)))
 
826
                       (setq sum (+ sum len 1)))
 
827
                     (setq i (1+ i)))) msgs))
 
828
      (throw 'done
 
829
             (or (not rest)
 
830
                 (elmo-archive-call-process prog (append args rest))))
 
831
      )))
 
832
 
 
833
(defsubst elmo-archive-article-exists-p (arc msg type)
 
834
  (if (not elmo-archive-check-existance-strict)
 
835
      t ; nop
 
836
    (save-excursion ; added 980915
 
837
      (let* ((method (elmo-archive-get-method type 'ls))
 
838
             (args (list arc msg))
 
839
             (buf (get-buffer-create " *ELMO ARCHIVE query*"))
 
840
             (error-msg "\\(no file\\|0 files\\)")
 
841
             ret-val)
 
842
        (set-buffer buf)
 
843
        (erase-buffer)
 
844
        (elmo-archive-call-method method args t)
 
845
        ;; pointer: point-max
 
846
        (setq ret-val (not (re-search-backward error-msg nil t)))
 
847
        (kill-buffer buf)
 
848
        ret-val))))
 
849
 
 
850
(defun elmo-archive-tgz-common-func (args exec-type &optional copy)
 
851
  (let* ((arc (car args))
 
852
         (tmp-msgs (cdr args))
 
853
         (decompress (elmo-archive-get-method 'tgz 'decompress))
 
854
         (compress (elmo-archive-get-method 'tgz 'compress))
 
855
         (exec (elmo-archive-get-method 'tgz exec-type))
 
856
         (suffix (elmo-archive-get-suffix 'tgz))
 
857
         (tar-suffix (elmo-archive-get-suffix 'tar))
 
858
         arc-tar ret-val
 
859
         )
 
860
    (when (null (and decompress compress exec))
 
861
      (ding)
 
862
      (error "WARNING: special method undefined: %s of %s"
 
863
             (or (if (null decompress) 'decompress)
 
864
                 (if (null compress) 'compress)
 
865
                 (if (null exec) exec-type))
 
866
             'tgz))
 
867
    (unless tar-suffix
 
868
      (ding)
 
869
      (error "WARNING: `tar' suffix undefined"))
 
870
    (if (string-match (concat (regexp-quote suffix) "$") arc)
 
871
        (setq arc-tar
 
872
              (concat (substring arc 0 (match-beginning 0)) tar-suffix))
 
873
      (error "%s: not match suffix [%s]" arc suffix))
 
874
    (and
 
875
     ;; decompress
 
876
     (elmo-archive-call-process
 
877
      (car decompress) (append (cdr decompress) (list arc)))
 
878
     ;; append (or delete)
 
879
     (elmo-archive-exec-msgs-subr2
 
880
      (car exec) (append (cdr exec) (list arc-tar)) tmp-msgs (length arc-tar))
 
881
     ;; compress
 
882
     (setq ret-val
 
883
           (elmo-archive-call-process
 
884
            (car compress) (append (cdr compress) (list arc-tar)))))
 
885
    ;; delete temporary messages
 
886
    (if (and (not copy)
 
887
             (eq exec-type 'append))
 
888
        (while tmp-msgs
 
889
          (if (file-exists-p (car tmp-msgs))
 
890
              (delete-file (car tmp-msgs)))
 
891
          (setq tmp-msgs (cdr tmp-msgs))))
 
892
    ret-val))
 
893
 
 
894
(defun elmo-archive-tgz-cp-func (args &optional output)
 
895
  (elmo-archive-tgz-common-func args 'append t))
 
896
 
 
897
(defun elmo-archive-tgz-mv-func (args &optional output)
 
898
  (elmo-archive-tgz-common-func args 'append))
 
899
 
 
900
(defun elmo-archive-tgz-rm-func (args &optional output)
 
901
  (elmo-archive-tgz-common-func args 'delete))
 
902
 
 
903
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
904
;;; MessageDB functions (from elmo-localdir.el)
 
905
 
 
906
(defsubst elmo-archive-msgdb-create-entity-subr (msgdb number)
 
907
  (let (header-end)
 
908
    (set-buffer-multibyte default-enable-multibyte-characters)
 
909
    (goto-char (point-min))
 
910
    (if (re-search-forward "\\(^--.*$\\)\\|\\(\n\n\\)" nil t)
 
911
        (setq header-end (point))
 
912
      (setq header-end (point-max)))
 
913
    (narrow-to-region (point-min) header-end)
 
914
    (elmo-msgdb-create-message-entity-from-buffer
 
915
     (elmo-msgdb-message-entity-handler msgdb) number)))
 
916
 
 
917
;; verrrry slow!!
 
918
(defsubst elmo-archive-msgdb-create-entity (msgdb
 
919
                                            method
 
920
                                            archive number type
 
921
                                            &optional prefix)
 
922
  (let* ((msg (elmo-concat-path prefix (int-to-string number)))
 
923
         (arg-list (list archive msg)))
 
924
    (when (elmo-archive-article-exists-p archive msg type)
 
925
      ;; insert article.
 
926
      (as-binary-process
 
927
       (elmo-archive-call-method method arg-list t))
 
928
      (elmo-archive-msgdb-create-entity-subr msgdb number))))
 
929
 
 
930
(luna-define-method elmo-folder-msgdb-create ((folder elmo-archive-folder)
 
931
                                              numbers flag-table)
 
932
  (when numbers
 
933
    (save-excursion ;; 981005
 
934
      (if (and elmo-archive-use-izip-agent
 
935
               (elmo-archive-get-method
 
936
                (elmo-archive-folder-archive-type-internal folder)
 
937
                'cat-headers))
 
938
          (elmo-archive-msgdb-create-as-numlist-subr2
 
939
           folder numbers flag-table)
 
940
        (elmo-archive-msgdb-create-as-numlist-subr1
 
941
         folder numbers flag-table)))))
 
942
 
 
943
(defun elmo-archive-msgdb-create-as-numlist-subr1 (folder numlist flag-table)
 
944
  (let* ((type (elmo-archive-folder-archive-type-internal folder))
 
945
         (file (elmo-archive-get-archive-name folder))
 
946
         (method (elmo-archive-get-method type 'cat))
 
947
         (new-msgdb (elmo-make-msgdb))
 
948
         entity i percent num message-id flags)
 
949
    (with-temp-buffer
 
950
      (setq num (length numlist))
 
951
      (setq i 0)
 
952
      (message "Creating msgdb...")
 
953
      (while numlist
 
954
        (erase-buffer)
 
955
        (setq entity
 
956
              (elmo-archive-msgdb-create-entity
 
957
               new-msgdb
 
958
               method file (car numlist) type
 
959
               (elmo-archive-folder-archive-prefix-internal folder)))
 
960
        (when entity
 
961
          (setq message-id (elmo-message-entity-field entity 'message-id)
 
962
                flags (elmo-flag-table-get flag-table message-id))
 
963
          (elmo-global-flags-set flags folder (car numlist) message-id)
 
964
          (elmo-msgdb-append-entity new-msgdb entity flags))
 
965
        (when (> num elmo-display-progress-threshold)
 
966
          (setq i (1+ i))
 
967
          (setq percent (/ (* i 100) num))
 
968
          (elmo-display-progress
 
969
           'elmo-archive-msgdb-create-as-numlist-subr1 "Creating msgdb..."
 
970
           percent))
 
971
        (setq numlist (cdr numlist)))
 
972
      (message "Creating msgdb...done")
 
973
      new-msgdb)))
 
974
 
 
975
;;; info-zip agent
 
976
(defun elmo-archive-msgdb-create-as-numlist-subr2 (folder
 
977
                                                   numlist
 
978
                                                   flag-table)
 
979
  (let* ((delim1 elmo-mmdf-delimiter)           ;; MMDF
 
980
         (delim2 elmo-unixmail-delimiter)       ;; UNIX Mail
 
981
         (type (elmo-archive-folder-archive-type-internal folder))
 
982
         (prefix (elmo-archive-folder-archive-prefix-internal folder))
 
983
         (method (elmo-archive-get-method type 'cat-headers))
 
984
         (prog (car method))
 
985
         (args (cdr method))
 
986
         (arc (elmo-archive-get-archive-name folder))
 
987
         (new-msgdb (elmo-make-msgdb))
 
988
         n i percent num msgs case-fold-search)
 
989
    (with-temp-buffer
 
990
      (setq num (length numlist))
 
991
      (setq i 0)
 
992
      (message "Creating msgdb...")
 
993
      (while numlist
 
994
        (setq n (min (1- elmo-archive-fetch-headers-volume)
 
995
                     (1- (length numlist))))
 
996
        (setq msgs (reverse (memq (nth n numlist) (reverse numlist))))
 
997
        (setq numlist (nthcdr (1+ n) numlist))
 
998
        (erase-buffer)
 
999
        (insert
 
1000
         (mapconcat
 
1001
          'concat
 
1002
          (mapcar '(lambda (x) (elmo-concat-path prefix (int-to-string x))) msgs)
 
1003
          "\n"))
 
1004
        (message "Fetching headers...")
 
1005
        (as-binary-process (apply 'call-process-region
 
1006
                                  (point-min) (point-max)
 
1007
                                  prog t t nil (append args (list arc))))
 
1008
        (goto-char (point-min))
 
1009
        (cond
 
1010
         ((looking-at delim1)   ;; MMDF
 
1011
          (elmo-msgdb-append
 
1012
           new-msgdb
 
1013
           (elmo-archive-parse-mmdf folder msgs flag-table)))
 
1014
;;;      ((looking-at delim2)   ;; UNIX MAIL
 
1015
;;;       (elmo-msgdb-append
 
1016
;;;        new-msgdb
 
1017
;;;        (elmo-archive-parse-unixmail msgs flag-table)))
 
1018
         (t                     ;; unknown format
 
1019
          (error "Unknown format!")))
 
1020
        (when (> num elmo-display-progress-threshold)
 
1021
          (setq i (+ n i))
 
1022
          (setq percent (/ (* i 100) num))
 
1023
          (elmo-display-progress
 
1024
           'elmo-archive-msgdb-create-as-numlist-subr2 "Creating msgdb..."
 
1025
           percent))))
 
1026
    new-msgdb))
 
1027
 
 
1028
(defun elmo-archive-parse-mmdf (folder msgs flag-table)
 
1029
  (let ((delim elmo-mmdf-delimiter)
 
1030
        (new-msgdb (elmo-make-msgdb))
 
1031
        number sp ep rest entity
 
1032
        message-id flags)
 
1033
    (goto-char (point-min))
 
1034
    (setq rest msgs)
 
1035
    (while (and rest (re-search-forward delim nil t)
 
1036
                (not (eobp)))
 
1037
      (setq number (car rest))
 
1038
      (setq sp (1+ (point)))
 
1039
      (setq ep (prog2 (re-search-forward delim)
 
1040
                   (1+ (- (point) (length delim)))))
 
1041
      (if (>= sp ep)                    ; no article!
 
1042
          ()                            ; nop
 
1043
        (save-excursion
 
1044
          (narrow-to-region sp ep)
 
1045
          (setq entity (elmo-archive-msgdb-create-entity-subr new-msgdb number)
 
1046
                message-id (elmo-message-entity-field entity 'message-id)
 
1047
                flags (elmo-flag-table-get flag-table message-id))
 
1048
          (elmo-global-flags-set flags folder number message-id)
 
1049
          (elmo-msgdb-append-entity new-msgdb entity flags)
 
1050
          (widen)))
 
1051
      (forward-line 1)
 
1052
      (setq rest (cdr rest)))
 
1053
    new-msgdb))
 
1054
 
 
1055
 
 
1056
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
1057
;;; Search functions
 
1058
 
 
1059
(defsubst elmo-archive-field-condition-match (folder number number-list
 
1060
                                                     condition prefix)
 
1061
  (save-excursion
 
1062
    (let* ((type (elmo-archive-folder-archive-type-internal folder))
 
1063
           (arc (elmo-archive-get-archive-name folder))
 
1064
           (method (elmo-archive-get-method type 'cat))
 
1065
           (args (list arc (elmo-concat-path prefix (int-to-string number)))))
 
1066
      (elmo-set-work-buf
 
1067
       (when (file-exists-p arc)
 
1068
         (as-binary-process
 
1069
          (elmo-archive-call-method method args t))
 
1070
         (set-buffer-multibyte default-enable-multibyte-characters)
 
1071
         (decode-mime-charset-region (point-min)(point-max) elmo-mime-charset)
 
1072
         (elmo-buffer-field-condition-match condition number number-list))))))
 
1073
 
 
1074
(luna-define-method elmo-folder-search ((folder elmo-archive-folder)
 
1075
                                        condition &optional from-msgs)
 
1076
  (let* (;;(args (elmo-string-to-list key))
 
1077
         ;; XXX: I don't know whether `elmo-archive-list-folder'
 
1078
         ;;      updates match-data.
 
1079
         ;; (msgs (or from-msgs (elmo-archive-list-folder spec)))
 
1080
         (msgs (or from-msgs (elmo-folder-list-messages folder)))
 
1081
         (num (length msgs))
 
1082
         (i 0)
 
1083
         (case-fold-search nil)
 
1084
         number-list ret-val)
 
1085
    (setq number-list msgs)
 
1086
    (while msgs
 
1087
      (if (elmo-archive-field-condition-match
 
1088
           folder (car msgs) number-list
 
1089
           condition
 
1090
           (elmo-archive-folder-archive-prefix-internal folder))
 
1091
          (setq ret-val (cons (car msgs) ret-val)))
 
1092
      (when (> num elmo-display-progress-threshold)
 
1093
        (setq i (1+ i))
 
1094
        (elmo-display-progress
 
1095
         'elmo-archive-search "Searching..."
 
1096
         (/ (* i 100) num)))
 
1097
      (setq msgs (cdr msgs)))
 
1098
    (nreverse ret-val)))
 
1099
 
 
1100
;;; method(alist)
 
1101
(if (null elmo-archive-method-alist)
 
1102
    (let ((mlist elmo-archive-method-list) ; from mew-highlight.el
 
1103
          method type str)
 
1104
      (while mlist
 
1105
        (setq method (car mlist))
 
1106
        (setq mlist (cdr mlist))
 
1107
        (setq str (symbol-name method))
 
1108
        (string-match "elmo-archive-\\([^-].*\\)-method-alist$" str)
 
1109
        (setq type (intern-soft
 
1110
                    (elmo-match-string 1 str)))
 
1111
        (setq elmo-archive-method-alist
 
1112
              (cons (cons type
 
1113
                          (symbol-value method))
 
1114
                    elmo-archive-method-alist)))))
 
1115
 
 
1116
;;; valid suffix(list)
 
1117
(if (null elmo-archive-suffixes)
 
1118
    (let ((slist elmo-archive-suffix-alist)
 
1119
          tmp)
 
1120
      (while slist
 
1121
        (setq tmp (car slist))
 
1122
        (setq elmo-archive-suffixes
 
1123
              (nconc elmo-archive-suffixes (list (cdr tmp))))
 
1124
        (setq slist (cdr slist)))))
 
1125
 
 
1126
(luna-define-method elmo-message-use-cache-p ((folder elmo-archive-folder)
 
1127
                                              number)
 
1128
  elmo-archive-use-cache)
 
1129
 
 
1130
;;; End
 
1131
(run-hooks 'elmo-archive-load-hook)
 
1132
 
 
1133
(require 'product)
 
1134
(product-provide (provide 'elmo-archive) (require 'elmo-version))
 
1135
 
 
1136
;;; elmo-archive.el ends here