From badd1112c7e8c3d7e0d08eafd2e2532208857d47 Mon Sep 17 00:00:00 2001 From: Chris Hanson <org/chris-hanson/cph> Date: Thu, 14 Jan 1999 21:30:55 +0000 Subject: [PATCH] Initial revision --- v7/src/edwin/pwedit.scm | 188 +++++++++++++++++++++++++++++++++++++++ v7/src/edwin/pwparse.scm | 176 ++++++++++++++++++++++++++++++++++++ 2 files changed, 364 insertions(+) create mode 100644 v7/src/edwin/pwedit.scm create mode 100644 v7/src/edwin/pwparse.scm diff --git a/v7/src/edwin/pwedit.scm b/v7/src/edwin/pwedit.scm new file mode 100644 index 000000000..1e6dfdcf2 --- /dev/null +++ b/v7/src/edwin/pwedit.scm @@ -0,0 +1,188 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: pwedit.scm,v 1.1 1999/01/14 21:30:55 cph Exp $ +;;; +;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; +;;; This program 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 2 of the +;;; License, or (at your option) any later version. +;;; +;;; This program 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 this program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; Password-Database Editor + +;;; This program provides editing capabilities for a text-format +;;; password database. The primary capability of this program is to +;;; permit editing a database of passwords without having all of the +;;; passwords visible on the screen at once. Instead, the program +;;; displays a set of key names, and the user selectively reveals the +;;; password information hidden behind those keys. + +(declare (usual-integrations)) + +(define-command view-password-file + "Read in a password file and show it in password-view mode." + "fView password file" + (lambda (pathname) + (let ((forms + (call-with-temporary-buffer " view-pw-file" + (lambda (buffer) + (read-buffer buffer pathname #f) + (read-pw-forms + (make-buffer-input-port (buffer-start buffer) + (buffer-end buffer))))))) + (let ((buffer (new-buffer (pathname->buffer-name pathname)))) + (insert-pw-forms forms (buffer-start buffer)) + (set-buffer-major-mode! buffer (ref-mode-object password-view)) + (set-buffer-point! buffer (buffer-start buffer)) + (select-buffer buffer))))) + +(define-major-mode password-view read-only "Password-View" + "Major mode specialized for viewing password files." + (lambda (buffer) + (set-buffer-read-only! buffer) + unspecific)) + +(define-key 'password-view #\space 'toggle-pw-form) +(define-key 'password-view button1-down 'mouse-toggle-pw-form) + +(define-command toggle-pw-form + "Toggle the body of the password form under point." + "d" + (lambda (point) + (if (get-pw-form point) + (toggle-pw-body point) + (message "No form under point.")))) + +(define-command mouse-toggle-pw-form + "Toggle the body of the password form under mouse." + () + (lambda () + ((ref-command toggle-pw-form) + (let ((button-event (current-button-event))) + (let ((window (button-event/window button-event))) + (select-window window) + (or (window-coordinates->mark window + (button-event/x button-event) + (button-event/y button-event)) + (buffer-end (window-buffer window)))))))) + + +(define (insert-pw-forms pw-forms point) + (let ((point (mark-left-inserting-copy point))) + (for-each + (lambda (form) + (let ((type (car form)) + (body (cdr form)) + (start (mark-right-inserting-copy point))) + (case type + ((BLANK) + (insert-newline point)) + ((COMMENT) + (for-each (lambda (line) + (insert-string ";" point) + (insert-string line point) + (insert-newline point)) + body)) + ((SHORT LONG) + (insert-string (car body) point) + (insert-string ":" point) + (insert-newline point)) + (else + (error "Unknown form type:" type))) + (region-put! start point 'PW-FORM form) + (mark-temporary! start))) + pw-forms) + (mark-temporary! point))) + +(define (get-pw-form point) + (let ((form (region-get point 'PW-FORM #f))) + (and form + (memq (car form) '(SHORT LONG)) + form))) + +(define (toggle-pw-body point) (modify-pw-body point 'TOGGLE)) +(define (insert-pw-body point) (modify-pw-body point 'INSERT)) +(define (delete-pw-body point) (modify-pw-body point 'DELETE)) + +(define (modify-pw-body point operation) + (with-buffer-open (mark-buffer point) + (lambda () + (let ((form + (or (get-pw-form point) + (error:bad-range-argument point 'INSERT-PW-BODY))) + (le (line-end point 0))) + (if (eq? 'SHORT (car form)) + (let ((region (short-pw-body-region point))) + (if region + (region-delete! region)) + (if (or (eq? 'INSERT operation) + (and (eq? 'TOGGLE operation) + (not region))) + (let ((end (mark-left-inserting-copy (line-end point 0)))) + (insert-pw-body-spacer end) + (insert-string (cddr form) end) + (mark-temporary! end)))) + (let ((region (long-pw-body-region point))) + (if region + (region-delete! region)) + (if (or (eq? 'INSERT operation) + (and (eq? 'TOGGLE operation) + (not region))) + (let ((end (mark-left-inserting-copy (line-end point 0)))) + (for-each (lambda (line) + (insert-newline end) + (if (pair? line) + (begin + (insert-string (car line) end) + (insert-string ":" end) + (insert-pw-body-spacer end) + (insert-string (cdr line) end)) + (insert-string line end))) + (cddr form)) + (mark-temporary! end))))))))) + +(define (short-pw-body-region point) + (let ((end (line-end point 0))) + (let ((start (next-specific-property-change* point end 'PW-FORM))) + (and start + (mark< start end) + (make-region start end))))) + +(define (long-pw-body-region point) + (let ((start (line-end point 0))) + (let ((end + (let loop ((m start)) + (let ((m* (mark1+ m))) + (if m* + (if (line-blank? m*) + m + (loop (line-end m* 0))) + m))))) + (and (mark< start end) + (make-region start end))))) + +(define (insert-pw-body-spacer point) + (insert-string (let ((column (mark-column point))) + (cond ((< column 8) "\t\t") + ((< column 16) "\t") + (else " "))) + point)) + +(define (next-specific-property-change* start end key) + (let ((index + (next-specific-property-change (mark-group start) + (mark-index start) + (mark-index end) + key))) + (and index + (make-mark (mark-group start) index)))) \ No newline at end of file diff --git a/v7/src/edwin/pwparse.scm b/v7/src/edwin/pwparse.scm new file mode 100644 index 000000000..a752abea3 --- /dev/null +++ b/v7/src/edwin/pwparse.scm @@ -0,0 +1,176 @@ +;;; -*-Scheme-*- +;;; +;;; $Id: pwparse.scm,v 1.1 1999/01/14 21:30:45 cph Exp $ +;;; +;;; Copyright (c) 1999 Massachusetts Institute of Technology +;;; +;;; This program 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 2 of the +;;; License, or (at your option) any later version. +;;; +;;; This program 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 this program; if not, write to the Free Software +;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. + +;;;; Password-Database Parser + +;;; This program implements I/O for a text-format password database. + +(declare (usual-integrations)) + +(define (read-pw-forms port) + (parse/neutral port '())) + +(define (parse/neutral port forms) + (let ((line (read-line port))) + (if (eof-object? line) + (finish-parsing forms) + (dispatch/neutral port line forms)))) + +(define (finish-parsing forms) + (reverse! forms)) + +(define (dispatch/neutral port line forms) + ((dispatch line + parse-neutral/blank + parse-neutral/comment + parse-neutral/short-form + parse-neutral/long-form) + port line forms)) + +(define (dispatch line + parse-blank + parse-comment + parse-short-form + parse-long-form) + (let ((start (string-find-next-char-in-set line char-set:not-whitespace)) + (end (string-length line))) + (cond ((not start) + parse-blank) + ((char=? #\; (string-ref line start)) + parse-comment) + (else + (let ((colon (substring-find-previous-char line start end #\:))) + (if colon + (if (substring-find-next-char-in-set line (+ colon 1) end + char-set:not-whitespace) + parse-short-form + parse-long-form) + parse-long-form)))))) + +(define (comment-line? line) + (let ((start (string-find-next-char-in-set line char-set:not-whitespace))) + (and start + (char=? #\; (string-ref line start))))) + +(define (long-form-separator-line? line) + ;; blank + (not (string-find-next-char-in-set line char-set:not-whitespace))) + +(define (split-colon-line line) + (let ((colon (string-find-next-char line #\:))) + (if colon + (cons (string-trim (string-head line colon)) + (string-trim (string-tail line (+ colon 1)))) + (strip-semicolons line)))) + +(define strip-semicolons + (let ((char-set (char-set-invert (char-set #\;)))) + (lambda (line) + (string-trim-left (string-trim line) char-set)))) + +(define (parse-neutral/blank port line forms) + line + (parse/neutral port (cons '(BLANK) forms))) + +(define (parse-neutral/comment port line forms) + (let ((finish-comment + (lambda (accumulator) + (cons (cons 'COMMENT (reverse! (map strip-semicolons accumulator))) + forms)))) + (let loop ((accumulator (list line))) + (let ((line (read-line port))) + (cond ((eof-object? line) + (finish-parsing (finish-comment accumulator))) + ((comment-line? line) + (loop (cons line accumulator))) + (else + (dispatch/neutral port + line + (finish-comment accumulator)))))))) + +(define (parse-neutral/short-form port line forms) + (parse/neutral port (cons (cons 'SHORT (split-colon-line line)) forms))) + +(define (parse-neutral/long-form port line forms) + (let* ((header + (string-trim + (let ((colon (string-find-previous-char line #\:))) + (if colon + (string-head line colon) + line)))) + (finish-long-form + (lambda (accumulator) + (cons (cons* 'LONG + header + (reverse! (map split-colon-line accumulator))) + forms)))) + (let loop ((accumulator '())) + (let ((line (read-line port))) + (cond ((eof-object? line) + (finish-parsing (finish-long-form accumulator))) + ((long-form-separator-line? line) + (dispatch/neutral port + line + (finish-long-form accumulator))) + (else + (loop (cons line accumulator)))))))) + +(define (write-pw-forms forms port) + (let ((write-two-part + (lambda (line) + (write-string (car line) port) + (write-char #\: port) + (let ((n + (+ (string-length (car line)) + 1))) + (if (< n 8) + (write-string "\t\t" port) + (write-char (if (< n 16) #\tab #\space) port))) + (write-string (cdr line) port)))) + (for-each (lambda (form) + (let ((type (car form)) + (body (cdr form))) + (case type + ((BLANK) + (newline port)) + ((COMMENT) + (for-each (lambda (line) + (write-char #\; port) + (write-string line port) + (newline port)) + body)) + ((SHORT) + (write-two-part body) + (newline port)) + ((LONG) + (write-string (car body) port) + (write-char #\: port) + (newline port) + (for-each (lambda (line) + (if (pair? line) + (write-two-part line) + (begin + (write-char #\; port) + (write-string line port))) + (newline port)) + (cdr body))) + (else + (error "Illegal form type:" form))))) + forms))) \ No newline at end of file -- 2.25.1