← Back to branch summary

~ubuntu-branches/debian/jessie/edb/jessie

« back to all changes in this revision

Viewing changes to .pc/20-cl-letf.patch/lisp/edb-1int-to-single.el

  • Committer: Package Import Robot
  • Author(s): Tatsuya Kinoshita, Jari Aalto, Tatsuya Kinoshita
  • Date: 2013-07-03 12:41:07 UTC
  • Revision ID: package-import@ubuntu.com-20130703124107-2ziqf4tke0jdbb9b
Tags: 1.31-3
http://bugs.debian.org/671585
[ Jari Aalto ]
* Move to packaging format "3.0 (quilt)".
* debian/clean
  - Delete test data.
* debian/compat
  - Update to 9.
* debian/control
  - (Build-Depends): Update to debhelper 9.
  - (Build-Depends-Indep): Add emacs24, rm emacs23, emacs22.
  - (Standards-Version): Update to 3.9.4.
  - (Vcs-*): Update to anonscm.debian.org.
* debian/copyright
  - Update to format 1.0
* debian/debian-vars.mk
  - Update variables.
* debian/emacsen-startup
  - (edb-debian-after-find-file): Preserve point, correct hook treatment.
    Patch thanks to Kevin Ryde <user42@zip.com.au> (Closes: #671585).
* debian/patches
  - (10): New. Use DESTDIR.
  - (20): New. Use cl-flet.
  - (22): New. Use called-interactively-p.
* debian/rules
  - Udate to dh(1)
  - (override_dh_auto_install): Delete duplicate file
    arb-demo and unneeded (see examples/README) symlinks to /dev/null
    and /etc/passwd.

[ Tatsuya Kinoshita ]
* debian/emacsen-install
  - (Install): Ignore old versions of GNU Emacs.
* debian/control
  - (Depends): Add emacs24, rm emacs23, emacs22.

Show diffs side-by-side

added added

removed removed

Lines of Context:
.pc/20-cl-letf.patch/lisp/edb-1int-to-single.el
 
1
;;; edb-1int-to-single.el
 
2
 
 
3
;; Copyright (C) 2006,2007,2008 Thien-Thi Nguyen
 
4
 
 
5
;; This file is part of EDB.
 
6
;;
 
7
;; EDB is free software; you can redistribute it and/or modify it under
 
8
;; the terms of the GNU General Public License as published by the Free
 
9
;; Software Foundation; either version 3, or (at your option) any later
 
10
;; version.
 
11
;;
 
12
;; EDB is distributed in the hope that it will be useful, but WITHOUT
 
13
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
14
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 
15
;; for more details.
 
16
;;
 
17
;; You should have received a copy of the GNU General Public License
 
18
;; along with EDB; see the file COPYING.  If not, write to the Free
 
19
;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
 
20
;; MA 02110-1301, USA.
 
21
 
 
22
;;; Commentary:
 
23
 
 
24
;; This file provides the single command `edb-1int-to-single',
 
25
;; as well as the feature by the same name.  See info file.
 
26
 
 
27
;;; Code:
 
28
 
 
29
(eval-when-compile (require 'cl))
 
30
(require 'edbcore)
 
31
 
 
32
(defun edb-1int-to-single (filename)
 
33
  "Translate contents of FILENAME to a \"single\" schema-schema.
 
34
If the contents are not in EDB 1.x \"internal file layout, format 0.7\",
 
35
signal an error.  Otherwise, leave the result of the translation in
 
36
a newly created output buffer named \":EDB (single) from FILENAME\".
 
37
 
 
38
The output buffer may have several \"<FIXME>\" tokens in it,
 
39
indicating places where further attention (a nice way to say
 
40
\"manual tweaking\") is required to complete the translation.
 
41
 
 
42
See info node `(edb)edb-1int-to-single' for the complete list
 
43
of possible <FIXME> occurances and suggested remedies."
 
44
  (interactive "fTranslate EDB 1.x \"internal file layout\": ")
 
45
  (let ((fixme "<FIXME>")
 
46
        ;; todo: for EDB 2.x, replace computation w/ (its) constant value
 
47
        (mm-idx (let ((slots (mapcar (lambda (ent)
 
48
                                       (intern (format ":%s" (car ent))))
 
49
                                     (get 'edb--v1-monolithic-mess
 
50
                                          'cl-struct-slots))))
 
51
                  (map 'list 'cons slots (number-sequence 0 (length slots)))))
 
52
        mm extra records coding loc-block locals)
 
53
    (flet ((elm () (let ((emacs-lisp-mode-hook nil))
 
54
                     (emacs-lisp-mode)))
 
55
           (mref (slot) (aref mm (cdr (assq slot mm-idx))))
 
56
           (cprop (prop &optional more) (insert (format "%s" prop)
 
57
                                                (if more
 
58
                                                    (format " %S" more)
 
59
                                                  "")
 
60
                                                "\n"))
 
61
           (nlnl (&optional stuff) (insert (if stuff
 
62
                                               (format "%s" stuff)
 
63
                                             "")
 
64
                                           "\n\n"))
 
65
           (nl () (insert "\n"))
 
66
           (backslash-hat (c) (cond ((= ?\n c) (insert c))
 
67
                                    ((> 32 c) (insert "\\^" (+ c 64)))
 
68
                                    (t (insert c)))))
 
69
      (with-temp-buffer
 
70
        (elm)
 
71
        (insert-file-contents filename)
 
72
        (goto-char (point-min))
 
73
        (unless (looking-at ";; Database file written by EDB; format 0.7")
 
74
          (error "Not in \"internal file layout, format 0.7\": %s" filename))
 
75
        (forward-line 1)
 
76
        (setq mm (read (current-buffer))
 
77
              extra (read (current-buffer))
 
78
              records (buffer-substring-no-properties
 
79
                       (progn (forward-line 1) (point))
 
80
                       (point-max))
 
81
              coding coding-system-for-read))
 
82
      (switch-to-buffer
 
83
       (generate-new-buffer
 
84
        (concat ":EDB (single) from " filename)))
 
85
      (buffer-disable-undo)
 
86
      (setq default-directory (file-name-directory filename))
 
87
      (elm)
 
88
      (let ((standard-output (current-buffer))
 
89
            v)
 
90
        (insert ":EDB (single) ;;; -*- mode:emacs-lisp; coding:")
 
91
        (princ (or coding fixme))
 
92
        (nlnl "; -*-")
 
93
        (cprop :name)
 
94
        (prin1 (or (mref :print-name) fixme))
 
95
        (nlnl)
 
96
        (cprop :fields)
 
97
        (pp (map 'vector 'cons (mref :fieldnames) (mref :recordfieldspecs)))
 
98
        (nl)
 
99
        (when (setq v (car (mref :field-priorities)))
 
100
          (cprop :field-order)
 
101
          (pp (apply 'vector
 
102
                     (flet ((ok (x) (cond ((symbolp x)
 
103
                                           x)
 
104
                                          ((numberp x)
 
105
                                           (aref (mref :fieldnames) x))
 
106
                                          (t
 
107
                                           (error "badness")))))
 
108
                       (mapcar (lambda (spec)
 
109
                                 (cond ((and (consp spec)
 
110
                                             (not (consp (cdr spec))))
 
111
                                        (ok (car spec)))
 
112
                                       ((consp spec)
 
113
                                        (cons (ok (car spec)) (cdr spec)))
 
114
                                       (t
 
115
                                        (ok spec))))
 
116
                               v))))
 
117
          (nl))
 
118
        (let ((fsub (mref :sub-fieldsep-string))
 
119
              (rsub (mref :sub-recordsep-string)))
 
120
          (when (or rsub fsub)
 
121
            (cprop :substitution-separators)
 
122
            (let ((standard-output 'backslash-hat))
 
123
              (pp (vector fsub rsub)))
 
124
            (nl)))
 
125
        (when (setq v (mref :substitutions))
 
126
          (cprop :substitutions)
 
127
          (let ((standard-output 'backslash-hat))
 
128
            (pp (apply 'vector v)))
 
129
          (nl))
 
130
        (let (try limit)
 
131
          (flet ((yes (c) (when c
 
132
                            (cprop :display t)
 
133
                            (setq limit (+ (cadr (insert-file-contents try))
 
134
                                           (point)))
 
135
                            (when (re-search-forward "\f*\nLocal Variables:\n"
 
136
                                                     limit 1)
 
137
                              (goto-char limit)
 
138
                              (setq loc-block (buffer-substring-no-properties
 
139
                                               (match-end 0) limit))
 
140
                              (delete-region (match-beginning 0) limit))
 
141
                            (unless (bolp)
 
142
                              (insert "\n"))
 
143
                            t)))
 
144
            (cond ((yes (and (setq try (assq :format-file extra))
 
145
                             (setq try (expand-file-name
 
146
                                        (cdr try)
 
147
                                        (file-name-directory filename)))
 
148
                             (file-readable-p try))))
 
149
                  ((yes (setq try (db-locate-readable-file-prefer-cwd
 
150
                                   (file-name-nondirectory
 
151
                                    (file-name-sans-extension filename))
 
152
                                   (cons (file-name-directory filename)
 
153
                                         db-format-file-path)
 
154
                                   db-format-file-suffixes))))
 
155
                  (t
 
156
                   (cprop :display (list (intern fixme)))
 
157
                   (insert fixme "\n"))))
 
158
          (nlnl :EOTB))
 
159
        (cprop :data '(:coding t :seqr read-line :EOTB ":EOTB"))
 
160
        (insert records ":EOTB")
 
161
        (when loc-block
 
162
          (goto-char (point-min))
 
163
          (forward-line 1)
 
164
          (insert "\n;;; From primary format file's local variables block:\n")
 
165
          (narrow-to-region (point) (point-max))
 
166
          (insert loc-block)
 
167
          (delete-region (point) (progn (search-backward "\nEnd:")
 
168
                                        (1+ (point))))
 
169
          (narrow-to-region (point-min) (point))
 
170
          (goto-char (point-min))
 
171
          (while (< (point) (point-max))
 
172
            (cond ((looking-at "^eval:")
 
173
                   (delete-char 5)
 
174
                   (let* ((opoint (point))
 
175
                          (form (read (current-buffer)))
 
176
                          (special (assq (car form)
 
177
                                         '((database-set-fieldnames-to-list
 
178
                                            "redundant")
 
179
                                           (dbf-set-summary-format
 
180
                                            :summary-format car)))))
 
181
                     (if special
 
182
                         (let* ((why (cadr special))
 
183
                                (blurb (if (stringp why)
 
184
                                           why
 
185
                                         (format "%s `%s' %s"
 
186
                                                 "translated to"
 
187
                                                 why
 
188
                                                 "control property")))
 
189
                                (xlat (caddr special)))
 
190
                           (delete-region opoint (progn (forward-line 1)
 
191
                                                        (point)))
 
192
                           (insert ";;*" blurb ":\n;; "
 
193
                                   (format "(%s ...)" (car form))
 
194
                                   "\n")
 
195
                           (when xlat
 
196
                             (save-excursion
 
197
                               (save-restriction
 
198
                                 (widen)
 
199
                                 (re-search-forward "^:data")
 
200
                                 (beginning-of-line)
 
201
                                 (cprop why)
 
202
                                 (let ((standard-output 'backslash-hat)
 
203
                                       (v (funcall xlat (cdr form))))
 
204
                                   (pp v)
 
205
                                   (if (stringp v)
 
206
                                       (nlnl)
 
207
                                     (nl)))))))
 
208
                       (goto-char opoint)
 
209
                       (delete-horizontal-space)
 
210
                       (indent-sexp)
 
211
                       (insert ";;*unhandled (" fixme "):\n")
 
212
                       (comment-region (point) (progn (forward-sexp 1)
 
213
                                                      (forward-line 1)
 
214
                                                      (point))))))
 
215
                  (t
 
216
                   (let* ((opoint (point))
 
217
                          (var (progn (looking-at "\\s-*\\([^:]+\\):\\s-*")
 
218
                                      (prog1 (intern (match-string 1))
 
219
                                        (goto-char (match-end 0)))))
 
220
                          (val (prog1 (read (current-buffer))
 
221
                                 (forward-line 1)))
 
222
                          (form `(set (make-local-variable ',var)
 
223
                                      ,(if (or (stringp val)
 
224
                                               (vectorp val))
 
225
                                           val
 
226
                                         (list 'quote val)))))
 
227
                     (case var
 
228
                       ((db-new-record-function
 
229
                         dbf-first-change-function
 
230
                         dbf-every-change-function
 
231
                         dbf-before-display-record-function
 
232
                         dbf-format-name-spec-alist
 
233
                         edb-data-coding)
 
234
                        (comment-region opoint (point))
 
235
                        (save-excursion
 
236
                          (goto-char opoint)
 
237
                          (insert ";;*special variable (" fixme "):\n")))
 
238
                       (t
 
239
                        (setq locals (acons var val locals))
 
240
                        (delete-region opoint (point))
 
241
                        (insert (format ";;*added to `:locals' %s: %s\n"
 
242
                                        "control property"
 
243
                                        var))))))))
 
244
          (widen)
 
245
          (delete-blank-lines))
 
246
        (goto-char (point-min))
 
247
        (when (setq locals (nconc (nreverse locals) (mref :locals)))
 
248
          (re-search-forward "^:data")
 
249
          (beginning-of-line)
 
250
          (cprop :locals)
 
251
          (pp (apply 'vector (mapcar (lambda (pair)
 
252
                                       (list (car pair) (cdr pair)))
 
253
                                     locals)))
 
254
          (nl))
 
255
        (goto-char (point-min))))))
 
256
 
 
257
(provide 'edb-1int-to-single)
 
258
 
 
259
;;; edb-1int-to-single.el ends here