|
Translations |
Profiles /
Pfv-modeDotEl;;; pfv-mode.el --- Package Freedom Verification for gNewSense project using Emacs
;; Copyright (C) 2007 Bake Timmons III
;; Version: alpha
;; Date: Tue 30-Nov-2007
;; Maintainer: Bake Timmons III <b3timmons@speedymail.org>
;; Description: Package Freedom Verification for gNewSense project using Emacs
;; Compatibility: Emacs22
;; This file is not part of GNU Emacs.
;; Emacs PFV Mode is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published
;; by the Free Software Foundation; either version 3, or (at your
;; option) any later version.
;; Emacs PFV Mode is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with Emacs PFV Mode; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; Emacs PFV Mode is intended to automate the process of entering data
;; for the Package Freedom Verification work undertaken by the
;; gNewSense project. This mode contains a few helpful functions that,
;; for example, convert back and forth between the PMWiki markup used to
;; present the data and a rough preview and editing mode for the markup.
;; Although PFV Mode has only been tested in recent copies of Emacs 22 from
;; cvs, there seems to be no particular reason why it should not be
;; compatible with a few older versions.
;; This is an alpha release due to how much more I want to do with it
;; and the fact that it is undocumented, but this mode has already
;; been tested successfully in helping to complete a PFV web page very
;; quickly. Please send ideas, code, comments, etc. to me.
;;; Contributors:
;;; Hacking notes:
;; 1. One touchy issue is the use of trailing slashes (/) in directory
;; names. While the slashes are omitted in the package names on
;; PFV pages, they need to be used in some other situations,
;; including with sorted directories. E.g., a listing in a web
;; browser shows directories with trailing slashes, which explains
;; alphabetical ordering such as: word-2/ word/ word3/
;;
;; That's because the ordering of the first unequal character, the
;; 5th, goes: '-' < '/' < '3'
;;
;; The code in a few spots is slightly more complicated because of
;; this issue.
;;
;;; TODO:
;; -Improve regexp performance and clarify their presentation with
;; named components. Also do more testing (e.g., other footnote formats?)
;; -Add more caching functionality: retrieve relevant lists of directories.
;; -Improve web fetching: e.g., more background activity.
;; -Add some kind of diff functionality that shows differences among license
;; documents in a listing. More generally, improve summarizing capability.
;; -More documentation.
;; -Think more about a guessing capability.
;;; Code:
(defvar pfv-tbl-headers-default ["Package" "License" "Free?"])
(defvar pfv-tbl-headers ())
(defvar pfv-tbl-width-default 79)
(defvar pfv-tbl-width nil)
(defvar pfv-tbl-horiz-char ?-)
(defvar pfv-tbl-vert-char ?|)
(defvar pfv-tbl-underline-char ?=)
(defvar pfv-tbl-corner-char ?+)
(defvar pfv-unknown-entry "?")
(defvar pfv-base-lic-url "http://changelogs.ubuntu.com/changelogs/pool/")
(defvar pfv-base-pkg-url "http://archive.gnewsense.org/gnewsense/pool/")
(defvar pfv-lic-list-url "http://www.gnu.org/philosophy/license-list.html")
(defvar pfv-lic-list-file "license-list.txt")
(defvar pfv-lic-choice-file "license-choices")
(defvar pfv-lic-choice-buffer nil)
(defvar pfv-tbl-col2-pos-default 20)
(defvar pfv-tbl-col3-pos-default 70)
(defvar pfv-tbl-col2-pos nil)
(defvar pfv-tbl-col3-pos nil)
(defvar pfv-overwrite t)
(defvar pfv-home (concat (getenv "HOME") "/.pfv/"))
(defvar pfv-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [(shift down)] 'pfv-down)
(define-key map [(shift up)] 'pfv-up)
(define-key map [(shift left)] 'pfv-left)
(define-key map [(shift right)] 'pfv-right)
(define-key map [(shift next)] 'pfv-next)
(define-key map [(shift prior)] 'pfv-prior)
(define-key map [(meta insert)] 'pfv-insert)
(define-key map [f9] 'pfv-view-license-list)
(define-key map (kbd "C-z") 'pfv-key)
(define-key map [f11] 'pfv-view-license-choices)
map)
"Keymap for `pfv-mode'.")
(defvar pfv-shortcuts "0123456789abcdefghijklmnopqrstuvwxyz")
(defvar pfv-tmp-file "pfv-tmp-file")
(setq default-directory pfv-home)
(define-derived-mode pfv-mode nil "PFV"
"Major mode for editing Package Freedom Verification data of gNewSense site.
The gNewSense GNU/Linux distribution currently presents this data using PMWiki
markup as a part of checking the freedom of the software it distributes. This
mode facilitates the editing process.")
(defun pfv-get-url (url return-form)
"Retrieve url and report contents depending on RETURN-FORM.
Return contents as a string if RETURN-FORM is 'string, as a
buffer if 'buffer, and as a filename if 'filename. Raise an
error for any other value. Return nil only in case of a failed
download."
(let* ((parsed-url (url-generic-parse-url url))
(filename (concat (aref parsed-url 4) (aref parsed-url 6)))
(filename (if (= (aref filename (1- (length filename))) ?/)
(concat filename "index.html") filename)))
(cond
((or (file-readable-p filename)
(and (zerop (call-process "wget" nil "PFV Download Log" nil
"--force-directories"
"--timestamping"
url))
(file-readable-p filename)))
(if (eq return-form 'filename) filename
(let ((buffer (generate-new-buffer filename)) (str nil))
(with-current-buffer buffer
(insert-file-contents filename)
(when (eq return-form 'string)
(setq str
(buffer-substring-no-properties (point-min) (point-max)))))
(cond (str (kill-buffer buffer) str) ; kill only when not current
((eq return-form 'buffer) buffer)
(t (error "Unrecognized symbol: '%s" return-form))))))
(t (message "Error reading and downloading %s" url) nil))))
(defun pfv-update-dir-names (url)
"Update current names of directories from a listing in page given by URL."
(let ((start 0) (names ()) (size 0) (str (pfv-get-url url 'string)))
(while (string-match "href=\"\\([a-z0-9][-+.a-z0-9]*/\\)\">\\1" str start)
(push (match-string 1 str) names)
(setq start (match-end 1) size (1+ size)))
(setq pfv-crnt-dir-names (vconcat (nreverse names))
pfv-num-crnt-dir-names size)))
(defun pfv-get-working-pkg-ver (url index)
"Find current version of package at URL and corresponding to WORKING-INDEX."
;; (message "%s %s %s" i name (aref pfv-working-pkgs 0))
(or (aref pfv-working-pkgs-versions index)
(let* ((start 0)
(str (pfv-get-url url 'string))
(latest "~~")) ;; dummy early version unlikely to be preceded
(while (string-match "_\\(.+?\\).dsc" str start)
(setq start (match-end 1)) ;; save before match data is messed up
(let ((match (match-string 1 str)))
(when (pfv-debian-ver< latest match) (setq latest match))))
(cond ((> start 0)
(aset pfv-working-pkgs-versions i latest))
(t (error "No version info found at the URL %s: \n%s"
url str) nil)))))
(defun pfv-get-all-working-pkg-ver ()
(interactive)
(let ((progress-reporter
(make-progress-reporter "Collecting current package info..."
0 pfv-num-working-pkgs)))
(dotimes (i pfv-num-working-pkgs)
(pfv-get-working-pkg-ver (concat (concat pfv-crnt-subsection-pkg-url
(aref pfv-working-pkgs i)))
i)
(progress-reporter-update progress-reporter i))
(progress-reporter-done progress-reporter)))
(defvar pfv-working-pkgs-lic-urls nil)
(defvar pfv-working-pkgs-pkg-urls nil)
(defvar pfv-pkg-suffix ".dsc")
(defun pfv-get-all-working-pkg-info ()
(interactive)
(let ((progress-reporter
(make-progress-reporter "Collecting current package info..."
0 pfv-num-working-pkgs)))
(dotimes (i pfv-num-working-pkgs)
(let* ((pkg-dir (aref pfv-working-pkgs i))
(pkg-name (substring pkg-dir 0 -1))
(pkg-ver (pfv-get-working-pkg-ver
(concat pfv-crnt-subsection-pkg-url pkg-dir)
i))
(lic-ver (if (string-match "\\(.*\\)gnewsense" pkg-ver)
(match-string 1 pkg-ver)
pkg-ver))
(base-path (concat pkg-dir pkg-name "_"))
(base-lic-url (concat pfv-crnt-subsection-lic-url
base-path
lic-ver
"/")))
(aset pfv-working-pkgs-pkg-urls i
(concat pfv-crnt-subsection-pkg-url
base-path pkg-ver pfv-pkg-suffix))
(cond ((or (and (setq url (concat base-lic-url "copyright"))
(pfv-get-url url 'buffer)) ; more likely
(and (setq url (concat base-lic-url pkg-name ".copyright"))
(pfv-get-url url 'buffer))) ; less likely
(aset pfv-working-pkgs-lic-urls i url))
(t (message "Error retrieving info on %s" pkg-name))))
(progress-reporter-update progress-reporter i))
(progress-reporter-done progress-reporter)))
(defvar pfv-working-url-regexp
(concat
"\\([A-Z][a-z0-9]+\\)" ;; (1) section name
"\\(?:\\(?:\\([A-Z][a-z0-9+.-]*[a-z0-9+.]*\\)" ;; (2) name of
"-\\([A-Z][a-z0-9+.-]*[a-z0-9+.]*\\)\\)" ;; subsection or
"\\|\\(?:\\([A-Z][a-z0-9+.]*\\)-\\([a-z0-9+.]*\\)\\)" ;; range within
"\\|\\([A-Z][a-z0-9+.]*\\)\\)")) ;; subsection
(defun pfv-subvector (vec start len)
"Return the subvector of size LEN starting at index START of VEC.
Arguments are assumed to be valid, so no error checking is done."
(let ((subvector (make-vector len nil)))
(dotimes (i len subvector)
(aset subvector i (aref vec (+ start i))))))
(defun pfv-update-working-pkgs (url)
"Update info about working packages based on the form of URL.
Global variables are updated with info on names, urls,
etc. relating to the packages fitting the description of the
given URL. nil is returned."
(let (url-suffix
(case-fold-search nil))
(if (string-match pfv-working-url-regexp url)
(let* ((section (concat (downcase (match-string 1 url)) "/"))
(subsections
(save-match-data
(pfv-update-dir-names
(concat pfv-base-pkg-url section))
pfv-crnt-dir-names)))
(setq pfv-crnt-section section
pfv-crnt-subsection-vector subsections
pfv-crnt-subsection-vector-size pfv-num-crnt-dir-names)
(if (match-string 6 url)
(let ((subsection (concat (downcase (match-string 6 url))
"/"))) ;; whole ss
(unless (pfv-get-pos-in-array subsections
pfv-crnt-subsection-vector-size
subsection
nil)
(error "Unknown subsection: %s" subsection))
(setq pfv-crnt-subsection subsection
url-suffix (concat section subsection))
(pfv-update-dir-names
(setq pfv-crnt-subsection-pkg-url
(concat pfv-base-pkg-url url-suffix)))
(setq pfv-working-pkgs pfv-crnt-dir-names
pfv-num-working-pkgs pfv-num-crnt-dir-names))
(let (ss-start ss-end ss-index) ;; partial ss
(if (match-string 2 url)
(setq ss-start (downcase (match-string 2 url))
ss-end (downcase (match-string 3 url)))
(setq ss-start (downcase (match-string 4 url))
ss-end (downcase (match-string 5 url))))
(unless
(setq ss-index
(pfv-get-pos-in-array subsections
pfv-crnt-subsection-vector-size
ss-start
-1))
(error "Out of range"))
(let ((subsection (aref subsections ss-index)))
(setq pfv-crnt-subsection subsection
url-suffix (concat section subsection))
(pfv-update-dir-names (setq pfv-crnt-subsection-pkg-url
(concat pfv-base-pkg-url
url-suffix)))
(let* ((bounds (pfv-get-bounded-indices pfv-crnt-dir-names
pfv-num-crnt-dir-names
ss-start
ss-end))
(start-pos (car bounds))
(end-pos (cadr bounds)))
(setq pfv-num-working-pkgs (- end-pos start-pos -1)
pfv-working-pkgs (pfv-subvector
pfv-crnt-dir-names
start-pos
pfv-num-working-pkgs)))))))
(error "Cannot find the range of packages"))
(setq pfv-crnt-subsection-lic-url (concat pfv-base-lic-url url-suffix)
pfv-crnt-pkgs pfv-crnt-dir-names
pfv-num-crnt-pkgs pfv-num-crnt-dir-names
pfv-working-pkgs-versions (make-vector pfv-num-working-pkgs nil)))
nil)
(defun pfv-refresh-files (base-url names)
(cond (pfv-auto-download
(write-region names nil pfv-tmp-file)
(start-process "pfv-dl-progress" "PFV Download Log"
"wget" "--force-directories"
"--timestamping"
(concat "--base=" base-url)
(concat "--input=" pfv-tmp-file))
(setq pfv-last-proc "pfv-dl-progress")
(t (message "pfv-auto-download not enabled")))))
(defun pfv-get-pos-in-array (a n s adjust)
"For array A with max index N, return lowest index of occurence of string S.
A is a sorted array of strings. If ADJUST equals 1 or -1, return
lowest index, with ADJUST possibly added (see conditions in
code). If ADJUST is nil and S is not found, return nil."
(let ((low 0) (high (1- n)) (match nil) i)
(while (<= low high)
(setq i (/ (+ low high) 2))
(cond ((string< (aref a i) s) (setq low (1+ i)))
((string= (aref a i) s) (setq low (1+ high) match t))
(t (setq high (1- i)))))
(if match
i
(if adjust
(if (or (and (= adjust 1) (< high i)) (and (= adjust -1) (> low i)))
i
(+ i adjust))))))
(defun pfv-get-bounded-indices (a n s u)
"For array A with max index N, return the subarray bounded by strings S and U.
A is a sorted array of strings. All elements of the subarray are
lexicographically greater than or equal to string S and less than
or equal to string T. If the subarray is empty, nil is returned;
otherwise a list of the start and end indices of the subarray in
A is returned."
(let ((low 0) (high (1- n)) (match nil) i)
(while (<= low high)
(setq i (/ (+ low high) 2))
(cond ((string< (aref a i) s) (setq low (1+ i)))
((string= (aref a i) s) (setq low (1+ high) match t))
(t (setq high (1- i)))))
(let ((i1 (if (or (and match (setq match nil ;; follow this with non-nil
low (1- low))) ;; undo "fake" low
(>= i low))
i (1+ i))))
(setq high (1- n)) ;; high value reset (low value reused)
(while (<= low high)
(setq i (/ (+ low high) 2))
(cond ((string< (aref a i) u) (setq low (1+ i)))
((string= (aref a i) u) (setq high (1- low) match t))
(t (setq high (1- i)))))
(let ((i2 (if (or match
(<= i high))
i (1- i))))
(and (<= i1 i2) (list i1 i2))))))
(setq pfv-debian-ver-regexp ;; NB: assumes entire version string is legal
(concat "^\\(?:\\([0-9]+\\):\\)?"
"\\(?:\\(.*\\)-+\\([^-]+\\)\\)$"
"\\|\\(.+\\)$"))
(defun pfv-debian-ver-order (c)
"Given C, return a numerical value so that C is considered in a
possibly different order than its normal ascii order. The new
ordering follows a convention specific to Debian versions."
(cond ((= c ?~) -1)
((or (and (>= c ?a) (<= c ?z)) (and (>= c ?A) (<= c ?Z))) c)
(t (+ c 256))))
(defun pfv-debian-ver-rev-cmp (revisiona sizea revisionb sizeb)
"Return 0 if REVISIONA equals REVISIONB, else return difference of characters.
SIZEA is the size of REVISIONA, SIZEB the size of REVISIONB.
These characters are the first pair of characters--one from
VERSIONA and one from VERSIONB--that differ in a comparison.
E.g., the difference between 'abc' and 'abe' is -2 since the
first difference is between 'c' and 'e' and this difference is
-2."
(catch 'loop
(let ((posa 0) (posb 0))
(while (or (< posa sizea) (< posb sizeb))
(let ((first_diff 0))
(while (let* ((chara (and (< posa sizea) (aref revisiona posa)))
(non-digit-chara-p
(and chara (or (> chara ?9) (< chara ?0))))
(charb (and (< posb sizeb) (aref revisionb posb)))
(non-digit-charb-p
(and charb (or (> charb ?9) (< charb ?0))))
(ac (if non-digit-chara-p (pfv-debian-ver-order chara)
0))
(bc (if non-digit-charb-p (pfv-debian-ver-order charb)
0))
(diff (- ac bc)))
(and (or non-digit-chara-p non-digit-charb-p)
(or (zerop diff)
(throw 'loop diff))))
(setq posa (1+ posa) posb (1+ posb)))
(while (and (< posa sizea) (= (aref revisiona posa) ?0))
(setq posa (1+ posa)))
(while (and (< posb sizeb) (= (aref revisionb posb) ?0))
(setq posb (1+ posb)))
(while (let* ((chara (and (< posa sizea) (aref revisiona posa)))
(digita-p (and chara (>= chara ?0) (<= chara ?9)))
(charb (and (< posb sizeb) (aref revisionb posb)))
(digitb-p (and charb (>= charb ?0) (<= charb ?9))))
(and digita-p digitb-p
(if (zerop first_diff)
(setq first_diff (- chara charb))
t)))
(setq posa (1+ posa) posb (1+ posb)))
(when (let ((chara (and (< posa sizea) (aref revisiona posa))))
(and chara (>= chara ?0) (<= chara ?9)))
(throw 'loop 1))
(when (let ((charb (and (< posb sizeb) (aref revisionb posb))))
(and charb(>= charb ?0) (<= charb ?9)))
(throw 'loop -1))
(unless (zerop first_diff)
(throw 'loop first_diff))))
0)))
(defun pfv-debian-ver-cmp (versiona versionb)
"Return 0 if VERSIONA equals VERSIONB, else return difference of characters.
The difference is similar to that for pfv-debian-ver-rev-cmp, but
this function assumes a (potentially) higher-level structure of
VERSIONA and VERSIONB that pfv-debian-ver-rev-cmp does not assume."
(string-match pfv-debian-ver-regexp versiona) ;; this and related functions
(let* ((epocha (match-string 1 versiona)) ;; are very close to those in
(debian-reva (match-string 3 versiona)) ;; the c sources of dpkg
(upstream-vera-loc (if debian-reva 2 4))
(upstream-vera (match-string upstream-vera-loc versiona)))
(string-match pfv-debian-ver-regexp versionb)
(let* ((epochb (match-string 1 versionb))
(debian-revb (match-string 3 versionb))
(upstream-verb-loc (if debian-revb 2 4))
(upstream-verb (match-string upstream-verb-loc versionb)))
(let ((val-epocha (if epocha (string-to-number epocha) 0))
(val-epochb (if epochb (string-to-number epochb) 0)))
(cond ((> val-epocha val-epochb) 1)
((< val-epocha val-epochb) -1)
((let ((cmp (pfv-debian-ver-rev-cmp
upstream-vera ; for short strings these
(length upstream-vera) ; length calls here seem
upstream-verb ; better than using
(length upstream-verb)))) ; match data which need
(unless (zerop cmp) cmp))) ; extra function calls
(t (pfv-debian-ver-rev-cmp debian-reva
(if debian-reva (length debian-reva)
0)
debian-revb
(if debian-revb (length debian-revb)
0))))))))
(defun pfv-debian-ver< (versiona versionb)
"Returns t if VERSIONA is less of a debian version than VERSIONB.
Otherwise, return nil."
(< (pfv-debian-ver-cmp versiona versionb) 0))
(defun pfv-reset ()
"Reset some global variables to empty values for PFV Mode."
(interactive)
(setq pfv-crnt-url nil
pfv-crnt-subsection-lic-url nil
pfv-crnt-subsection-pkg-url nil
pfv-crnt-subsection-vector nil
pfv-crnt-subsection-vector-size nil
pfv-crnt-pkgs nil
pfv-num-crnt-pkgs nil
pfv-working-pkgs nil
pfv-num-working-pkgs nil
pfv-working-pkgs-versions nil))
(defun pfv-top (url)
"Given URL, produce the corresponding PFV table in a buffer.
Generates a new table with data even if run before on URL."
(interactive "MURL of PFV page to edit: ")
(setq pfv-crnt-url url)
(setq pfv-tbl-headers pfv-tbl-headers-default
pfv-tbl-col2-pos pfv-tbl-col2-pos-default
pfv-tbl-col3-pos pfv-tbl-col3-pos-default
pfv-tbl-width pfv-tbl-width-default)
(pfv-update-working-pkgs url)
;; (let ((names (mapconcat 'identity pfv-crnt-pkgs "\n")
;; (pfv-refresh-files pfv-crnt-subsection-lic-url )))
(setq pfv-working-pkgs-lic-urls (make-vector pfv-num-working-pkgs nil)
pfv-working-pkgs-pkg-urls (make-vector pfv-num-working-pkgs nil))
(pfv-get-all-working-pkg-info)
(let ((packages (make-vector pfv-num-working-pkgs nil)))
(dotimes (i pfv-num-working-pkgs)
(let ((pkg (aref pfv-working-pkgs i)))
(when (>= (length pkg) pfv-tbl-col2-pos)
(setq pfv-tbl-col2-pos (1+ (length pkg))))
(aset packages i (vector pkg "" "" "" "" ""))))
(if packages
(pfv-output-tbl pfv-crnt-subsection-lic-url
pfv-crnt-subsection-pkg-url
packages
"")
(error "Empty package list"))))
(defun pfv-crnt-pkg-name ()
(save-excursion
(and (move-beginning-of-line nil)
(looking-at "|\\([a-z0-9][-+.a-z0-9]+\\) *|")
(match-string 1))))
(defun pfv-goto-first-pkg ()
(goto-char (point-min))
(let ((case-fold-search nil)) (search-forward "Package"))
(forward-line 2)
(move-beginning-of-line nil)
(or (looking-at "|[a-z0-9][-+.a-z0-9]+ *|")
(error "Table is empty or has bad format")))
(defun pfv-working-index-at-point ()
(pfv-restore-data-to-crnt-buffer)
(let* ((pkg-name (or (pfv-crnt-pkg-name) ;; how to improve here?
(and (pfv-goto-first-pkg) (pfv-crnt-pkg-name)))))
(pfv-get-pos-in-array pfv-working-pkgs
pfv-num-working-pkgs
(concat pkg-name "/")
nil)))
(defun pfv-dl-pkg ()
"For the package name on the current line, download its associated files.
Upon completion of downloading, a listing of the directory
containing the files is shown in another window becomes the
current buffer."
(interactive)
(let* ((i (pfv-working-index-at-point))
(url (aref pfv-working-pkgs-pkg-urls i))
(dsc-buffer (pfv-get-url url 'buffer)))
(unless dsc-buffer
(error "Error reading and downloading %s" url)) ; needed for all files!
(string-match "^\\([^:]+://\\(\\(?:.+/\\)+\\)\\)" url)
(let ((base-url (match-string 1 url))
(base-dir (match-string 2 url))
(pkg-name (aref pfv-working-pkgs i)))
(with-current-buffer dsc-buffer
(re-search-forward "^Files:")
(while (re-search-forward
(concat "\\(" pkg-name "_.*\\)$") nil t)
(let* ((url2 (concat base-url (match-string 1)))
(filename (pfv-get-url url2 'filename)))
(unless filename ; make this non-fatal, to try other files:
(message "Error reading and downloading %s" url2)))))
(kill-buffer dsc-buffer)
(dired-other-window base-dir)
(revert-buffer)))) ; might be overkill
(defun pfv-untar-pkg ()
(interactive)
(let* ((i (pfv-working-index-at-point))
(url (aref pfv-working-pkgs-pkg-urls i)))
(string-match "[^:]+://\\(\\(?:.+/\\)+\\)" url)
(let* ((dir (match-string 1 url))
(pkg-name (aref pfv-working-pkgs i))
(status (call-process-shell-command
"tar" nil nil nil
"--directory" dir
"--gunzip" "--extract" "--file"
(concat dir pkg-name "*.tar.gz"))))
(unless (zerop status)
(error "Error untarring the tar file for %s" pkg-name))
(dired-other-window dir)
(revert-buffer)))) ; might be overkill
(defun pfv-next ()
(interactive)
;; (when (one-window-p)
;; (split-window-horizontally))
(let* ((pkg-index (pfv-working-index-at-point))
(buffer (pfv-get-url (aref pfv-working-pkgs-lic-urls pkg-index)
'buffer)))
(view-buffer-other-window buffer)
(other-window 1)
(move-beginning-of-line nil)
(search-forward "|" nil 0 2)))
(defun pfv-key2license-name (key)
(with-current-buffer pfv-lic-choice-buffer
(goto-char (point-min))
(cond ((re-search-forward (concat key ":" " *\\(.*\\)$") nil t)
(match-string 1))
(t (error "Undefined shortcut: %s" key) ""))))
(defun pfv-key ()
(interactive)
(let ((key (read-char)))
(cond (t (let ((lic (pfv-key2license-name (string key))))
(when pfv-overwrite (delete-char (length lic)))
(insert lic))))))
(defun pfv-view-license-list ()
(interactive)
(unless (file-readable-p pfv-lic-list-file)
(unless (zerop
(call-process "lynx" nil pfv-lic-list-file nil
"-nonumbers"
"-dump" pfv-lic-list-url))
(error "Error retrieving license info")))
(save-selected-window (view-file-other-window pfv-lic-list-file)))
(defconst pfv-start-page-regexp ;; How a typical pfv page starts:
(concat "\\(^[a-z]+://.*$\\)\n" ;; lic url
"+\n" ;; blank line(s)
"\\(^[a-z]+://.*$\\)\n" ;; package url
"\[^(]+\n")) ;; unessential stuff
(defconst pfv-markup-tbl-start-regexp
(concat "\(:table\\(?: .*\\)?:)\n" ;; (:table:) directive
"\(:cell\\(?:nr\\)?:) *\\(.*$\\)\n" ;; header 1
"\(:cell:) *\\(.*$\\)\n" ;; header 2
"\(:cell:) *\\(.*$\\)")) ;; header 3
(defvar pfv-markup-start-regexp nil)
(unless pfv-markup-start-regexp
(setq pfv-markup-start-regexp
(concat pfv-start-page-regexp pfv-markup-tbl-start-regexp)))
(defconst pfv-markup-tbl-row-regexp ;; How typical row looks now:
(concat ;; pkg...license...free?
"(:cellnr:) *\\([a-z0-9][-+.a-z0-9]+\\)/? *\n" ;; pkg name field
"\(:cell:) *\\([^]|]+" ;; license field (split here)
"\\(?:|\\([^]']+\\)\\(\\(?:'\\^\\[.*\\]\\^'\\)+\\)?\\)?\\]\\]\\)?"
"\\(\\(?:'\\^\\[.*\\]\\^'\\)+\\)? *\n"
"\(:cell:) *\\([[:alpha:]]+\\)*" ;; "free?" field (split here)
"\\(\\(?:'\\^\\[.*\\]\\^'\\)+\\)? *"))
(defconst pfv-markup-tbl-end-regexp ;; How a typical pfv table ends
"(:tableend\\(?: .*\\)?:)")
(defconst pfv-pname-col 0
"Column number of package name in a PFV row.")
(defconst pfv-linfo-col 1
"Column number of license info in a PFV row.")
(defconst pfv-free?-col 2
"Column number of freedom status in a PFV row.")
(defconst pfv-lnames-col 3
"Column number of license name(s) in a PFV row.")
(defconst pfv-lref-col 4
"Column number of license footnotes in a PFV row.")
(defconst pfv-fref-col 5
"Column number of freedom status footnotes in a PFV row.")
(defun pfv-markup-ref2tbl-ref (ref)
"Returns a reference string from given markup string."
(if ref
(replace-regexp-in-string "\\]\\^''\\^\\[" ","
(substring-no-properties ref 2 -2))
""))
(defun pfv-markup2tbl ()
(interactive)
(setq pfv-tbl-col2-pos pfv-tbl-col2-pos-default
pfv-tbl-col3-pos pfv-tbl-col3-pos-default
pfv-tbl-width pfv-tbl-width-default)
(goto-char (point-min))
(if (re-search-forward pfv-markup-start-regexp nil t)
(let ((lic-url (match-string 1))
(pkg-url (match-string 2))
(headers (vector
(match-string 3) (match-string 4) (match-string 5))) ;use?
(rows (make-vector pfv-num-working-pkgs) nil)
(extra-text nil)
(i 0))
(while (and (< i pfv-num-working-pkgs)
(goto-char (match-end 0))
(forward-line 1)
(move-beginning-of-line nil)
(looking-at pfv-markup-tbl-row-regexp))
(let ((pname (match-string 1))
(licinfo (match-string 2))
(free? (match-string 6))
(lnames (match-string 3))
(lref (concat ;; why should strings at 4 & 5 NOT be appended?
(pfv-markup-ref2tbl-ref (match-string 4))
(pfv-markup-ref2tbl-ref (match-string 5))))
(fref (pfv-markup-ref2tbl-ref (match-string 7))))
(when (>= (+ 2 (length pname))
pfv-tbl-col2-pos)
(setq pfv-tbl-col2-pos (1+ (length pname))))
(when (>= (+ 2 (length lnames) (length lref) pfv-tbl-col2-pos)
pfv-tbl-col3-pos)
(setq pfv-tbl-col3-pos
(+ 2 (length lnames) (length lref) pfv-tbl-col2-pos)))
(when (>= (+ 2 pfv-tbl-col3-pos (length free?) (length fref))
pfv-tbl-width)
(setq pfv-tbl-width (+ 2 pfv-tbl-col3-pos (length free?)
(length fref))))
(aset rows (vector pname licinfo free? lnames lref fref) i)
(setq i (1+ i))))
(unless (and (move-beginning-of-line nil) ;; on correct line from loop
(looking-at pfv-markup-tbl-end-regexp))
(error "Improper table ending"))
(forward-line 1)
(move-beginning-of-line nil)
(setq extra-text (buffer-substring (point) (point-max)))
(pfv-output-tbl lic-url pkg-url rows extra-text))
(error "PFV format not recognized")))
;;; ***** Keep Alist and functions together to maintain consistency ***** TOP
(defvar pfv-buffer-data-alist ()
"This list holds buffers and their associated PFV data.
Past data can be fetched from this list and worked on again.")
(defun pfv-update-buffer-data-alist (buffer)
"Record BUFFER along with its its PFV data. Entire record is returned."
(push (list buffer
pfv-crnt-url
pfv-crnt-section
pfv-crnt-subsection
pfv-crnt-subsection-lic-url
pfv-crnt-subsection-pkg-url
pfv-crnt-subsection-vector
pfv-crnt-subsection-vector-size
pfv-crnt-pkgs
pfv-num-crnt-pkgs
pfv-working-pkgs
pfv-num-working-pkgs
pfv-working-pkgs-versions
pfv-working-pkgs-lic-urls
pfv-working-pkgs-pkg-urls)
pfv-buffer-data-alist))
(defun pfv-restore-data-to-crnt-buffer ()
"Restore any PFV data associated with the current buffer and return t.
If no data is found, return nil."
(interactive)
(let ((buffer (current-buffer)))
(unless (eq buffer pfv-crnt-buffer)
(let ((buffer-data (assq buffer pfv-buffer-data-alist))
(global-vars '(pfv-crnt-url
pfv-crnt-section
pfv-crnt-subsection
pfv-crnt-subsection-lic-url
pfv-crnt-subsection-pkg-url
pfv-crnt-subsection-vector
pfv-crnt-subsection-vector-size
pfv-crnt-pkgs
pfv-num-crnt-pkgs
pfv-working-pkgs
pfv-num-working-pkgs
pfv-working-pkgs-versions
pfv-working-pkgs-lic-urls
pfv-working-pkgs-pkg-urls)))
(cond (buffer-data (dolist (val (cdr buffer-data))
(set (pop global-vars) val)) ;; NB: use set here!
(setq pfv-crnt-buffer buffer)
t)
(t nil))))))
;;; ***** Keep Alist and functions together to maintain consistency ***** BOTTOM
(defun pfv-output-tbl (lic-url pkg-url rows extra-text)
"Print a PFV table for entering info on the PKG-SET directory of packages."
(let ((buffer (generate-new-buffer "*PFV Draft*"))
(last-col (1- pfv-tbl-width))
(outer-horiz-line
(concat (string pfv-tbl-corner-char)
(make-string (- pfv-tbl-width 2) pfv-tbl-horiz-char)
(string pfv-tbl-corner-char ?\n))))
(pfv-update-buffer-data-alist buffer)
(setq pfv-crnt-buffer buffer)
(switch-to-buffer buffer)
(insert lic-url "\n\n" ;; new line
pkg-url "\n\n" ;; new line
outer-horiz-line ;; new line
pfv-tbl-vert-char (aref pfv-tbl-headers 0)) ;; new line
(insert-char ?\s (- pfv-tbl-col2-pos (current-column)))
(insert pfv-tbl-vert-char (aref pfv-tbl-headers 1))
(insert-char ?\s (- pfv-tbl-col3-pos (current-column)))
(insert pfv-tbl-vert-char (aref pfv-tbl-headers 2))
(insert-char ?\s (- last-col (current-column)))
(insert pfv-tbl-vert-char ?\n
pfv-tbl-vert-char) ;; new line
(insert-char pfv-tbl-underline-char (1- pfv-tbl-col2-pos))
(insert pfv-tbl-corner-char)
(insert-char pfv-tbl-underline-char (- pfv-tbl-col3-pos pfv-tbl-col2-pos 3))
(insert pfv-tbl-corner-char)
(insert-char pfv-tbl-underline-char (- pfv-tbl-width pfv-tbl-col3-pos))
(insert pfv-tbl-vert-char ?\n)
(dotimes (i pfv-num-working-pkgs)
(let* ((r (aref rows i))
(pkg-name (aref r pfv-pname-col))
(pkg-name-end-char-pos (1- (length pkg-name)))
(pkg-name (if (= (aref pkg-name pkg-name-end-char-pos) ?/)
(substring pkg-name 0 pkg-name-end-char-pos)
pkg-name)) ;; no "/" to strip off of the end
(linfo (concat (aref r pfv-lnames-col) (aref r pfv-lref-col)))
(linfo (if (string= linfo "") pfv-unknown-entry linfo))
(free? (concat (aref r pfv-free?-col) (aref r pfv-fref-col)))
(free? (if (string= free? "") pfv-unknown-entry free?)))
(insert pfv-tbl-vert-char pkg-name)
(insert-char ?\s (- pfv-tbl-col2-pos (current-column)))
(insert pfv-tbl-vert-char linfo)
(insert-char ?\s (- pfv-tbl-col3-pos (current-column)))
(insert pfv-tbl-vert-char free?)
(insert-char ?\s (- last-col (current-column)))
(insert pfv-tbl-vert-char ?\n))) ;; new line in loop
(insert outer-horiz-line ?\n ;; new line
extra-text) ;; remaining lines
(pfv-mode)))
(setq pfv-tbl-start-regexp
(concat
"\\(^[a-z]+://.*\\)\n" ;; lic url
"+\n" ;; blank line(s)
"\\([a-z]+://.*\\)\n" ;; package url
"[^|]+" ;; unessential stuff
"| *\\([^|]*[^| ]\\) *" ;; headers
"| *\\([^|]*[^| ]\\) *"
"| *\\([^|]*[^| ]\\) *"))
(setq pfv-tbl-row-regexp
"| *\\([a-z0-9][-+.a-z0-9]*\\) *| *\\([^|]*[^| ]\\) *| *\\([^|]*[^| ]\\)")
(defun pfv-tbl2markup ()
(interactive)
(pfv-restore-data-to-crnt-buffer)
(goto-char (point-min))
(if (re-search-forward pfv-tbl-start-regexp nil t)
(let ((lic-url (match-string 1))
(pkg-url (match-string 2))
(header1 (match-string 3))
(header2 (match-string 4))
(header3 (match-string 5))
(rows (make-vector pfv-num-working-pkgs nil))
(i 0))
(forward-line 2)
(move-beginning-of-line nil)
(while (and (< i pfv-num-working-pkgs) (looking-at pfv-tbl-row-regexp))
(forward-line 1)
(aset rows
i
(vector (concat (match-string 1) "/")
(match-string 2)
(match-string 3)))
(setq i (1+ i)))
(forward-line 2)
(move-beginning-of-line nil)
(setq extra-text (buffer-substring (point) (point-max)))
(pfv-output-markup lic-url
pkg-url
(list header1 header2 header3)
rows
extra-text))
(error "PFV format not recognized")))
;; why not args corresponding w/ pfv-output-tbl?
(defun pfv-output-markup (lic-url pkg-url headers rows extra-text)
(let ((buffer (generate-new-buffer "*PFV Markup*")))
(switch-to-buffer buffer)
(insert lic-url "\n\n"
pkg-url "\n\n"
"(:table border=1 cellpadding=5 cellspacing=0:)\n")
(dolist (h headers)
(insert "(:cell:) '''" h "'''\n"))
(dotimes (i pfv-num-working-pkgs)
(let* ((r (aref rows i))
(pkg-name (aref r 0))
(pkg-name-end-char-pos (1- (length pkg-name)))
pkg-name2)
(if (= (aref pkg-name pkg-name-end-char-pos) ?/) ;; standardize on "/"
(setq pkg-name2 pkg-name
pkg-name (substring pkg-name 0 pkg-name-end-char-pos))
(setq pkg-name2 (concat pkg-name "/")))
(insert "(:cellnr:) " pkg-name ?\n
"(:cell:) [[" lic-url pkg-name "/" pkg-name "_"
(pfv-get-working-pkg-ver
pkg-url
(pfv-get-pos-in-array pfv-working-pkgs
pfv-num-working-pkgs
pkg-name2
nil))
"/" pkg-name ".copyright"
"|" (aref r 1) "]]\n"
"(:cell:) " (aref r 2) ?\n)))
(insert "(:tableend:)\n" extra-text)))
(defun pfv-view-license-choices ()
(interactive)
(unless (file-readable-p pfv-lic-choice-file)
(error "No license choice file exists"))
(let ((lic-choices (find-file-noselect pfv-lic-choice-file)))
(with-current-buffer lic-choices
(goto-char (point-min))
(unless (looking-at ".:") ; unless file shows shortcuts
(let ((i 0))
(while (and (< i (length pfv-shortcuts)) (not (eobp)))
(insert (aref pfv-shortcuts i) ": ")
(forward-line 1)
(setq i (1+ i)))
(unless (eobp)
(error "All shortcuts have been assigned"))))
(set-buffer-modified-p nil)
(setq buffer-read-only t))
(setq pfv-lic-choice-buffer lic-choices)
(save-selected-window
(other-window 1)
(switch-to-buffer lic-choices))))
|