[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/VSyK8tNp    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Oct 16:
#! /usr/bin/scheme --script

; put, get, dir -- version control system

(define (read-line . port)
  (define (eat p c)
    (if (and (not (eof-object? (peek-char p)))
             (char=? (peek-char p) c))
        (read-char p)))
  (let ((p (if (null? port) (current-input-port) (car port))))
    (let loop ((c (read-char p)) (line '()))
      (cond ((eof-object? c) (if (null? line) c (list->string (reverse line))))
            ((char=? #\newline c) (eat p #\return) (list->string (reverse line)))
            ((char=? #\return c) (eat p #\newline) (list->string (reverse line)))
            (else (loop (read-char p) (cons c line)))))))

(define (string-split sep str)
  (define (f cs xs) (cons (list->string (reverse cs)) xs))
  (let loop ((ss (string->list str)) (cs '()) (xs '()))
    (cond ((null? ss) (reverse (if (null? cs) xs (f cs xs))))
          ((char=? (car ss) sep) (loop (cdr ss) '() (f cs xs)))
          (else (loop (cdr ss) (cons (car ss) cs) xs)))))

(define (string-join sep ss)
  (define (f s ss)
    (string-append s (string sep) ss))
  (define (join ss)
    (if (null? (cdr ss)) (car ss)
      (f (car ss) (join (cdr ss)))))
  (if (null? ss) "" (join ss)))

(define (mktemp prefix)
  (let loop ((n 0))
    (let ((file (string-append prefix (number->string n))))
      (if (file-exists? file) (loop (+ n 1)) file))))

(define-syntax with-input-from-shell
  (syntax-rules ()
    ((with-input-from-shell cmd proc)
      (let ((temp-file (mktemp "shell")) (result #f))
        (system (string-append cmd " > " temp-file))
        (with-input-from-file temp-file
          (lambda () (set! result (proc))))
        (delete-file temp-file)
        result))))

(define (get file-name hist-file-name version)
  (cond ((not (file-exists? hist-file-name))
          (error 'get "missing history file"))
  (else (when (file-exists? file-name) (delete-file file-name))
        (with-input-from-file hist-file-name (lambda ()
          (let ((base-file (mktemp "get")))
            (with-output-to-file base-file (lambda ()
              (read-line) ; throw away header
              (let loop ((line (read-line)))
                (unless (or (eof-object? line)
                            (and (< 3 (string-length line))
                                 (string=? (substring line 0 3) "@@@")))
                  (display line) (newline) (loop (read-line))))))
            (let ((cmd-file (mktemp "get")))
              (with-output-to-file cmd-file (lambda ()
                (let loop ((version version))
                  (when (positive? version)
                    (when (eof-object? (peek-char))
                      (delete-file base-file) (delete-file cmd-file)
                      (error 'get "version doesn't exist"))
                    (let loop ((line (read-line)))
                      (unless (or (eof-object? line)
                                  (and (< 3 (string-length line))
                                       (string=? (substring line 0 3) "@@@")))
                        (display line) (newline) (loop (read-line))))
                    (loop (- version 1))))
                (display "w ") (display file-name) (newline)
                (display "q") (newline)))
              (system (string-append "ed -s " base-file " <" cmd-file))
              (delete-file base-file) (delete-file cmd-file))))))))

(define (put file-name hist-file-name whoami date comment)
  (cond ((not (file-exists? hist-file-name))
          (with-output-to-file hist-file-name (lambda ()
            (display "@@@ ") (display whoami) (display " ")
            (display date) (display " ") (display comment) (newline)
            (with-input-from-file file-name (lambda ()
              (let loop ((line (read-line)))
                (unless (eof-object? line)
                  (display line) (newline) (loop (read-line)))))))))
  (else (let ((old-file (mktemp "put"))
              (header (with-input-from-file hist-file-name
                        (lambda () (read-line)))))
          (get old-file hist-file-name 0)
          (let ((new-hist-file (mktemp "put")))
            (with-output-to-file new-hist-file (lambda ()
              (display "@@@ ") (display whoami) (display " ")
              (display date) (display " ") (display comment) (newline)
              (with-input-from-file file-name (lambda ()
                (let loop ((line (read-line)))
                  (unless (eof-object? line)
                    (display line) (newline) (loop (read-line))))))
              (display header) (newline)
              (with-input-from-shell
                (string-append "diff -e " file-name " " old-file)
                (lambda ()
                  (let loop ((line (read-line)))
                    (unless (eof-object? line)
                      (display line) (newline) (loop (read-line))))))
              (let ((count (with-input-from-shell
                             (string-append "wc -l <" old-file)
                             (lambda () (string->number (read-line))))))
                (with-input-from-file hist-file-name (lambda ()
                  (let loop ((count (+ count 1)))
                    (when (positive? count) (read-line) (loop (- count 1))))
                  (let loop ((line (read-line)))
                    (unless (eof-object? line)
                      (display line) (newline) (loop (read-line)))))))))
            (system (string-append "mv " new-hist-file " " hist-file-name))
            (delete-file old-file))))))

(define (dir hist-file-name)
  (with-input-from-file hist-file-name
    (lambda ()
      (let loop ((num 0) (line (read-line)))
        (when (not (eof-object? line))
          (cond ((and (< 3 (string-length line))
                      (string=? (substring line 0 3) "@@@"))
                  (display num) (display " ")
                  (display (substring line 4 (string-length line))) (newline)
                  (loop (+ num 1) (read-line)))
          (else (loop num (read-line)))))))))

(let ((prog-name (with-input-from-shell
                   (string-append "basename " (car (command-line)))
                   (lambda () (read-line))))
      (args (cdr (command-line))))
  (if (null? args)
      (cond ((string=? prog-name "put")
              (error 'put "usage: put file-name comment"))
            ((string=? prog-name "get")
              (error 'get "usage: get file-name [version]"))
            ((string=? prog-name "dir")
              (error 'dir "usage: dir file-name"))
            (else (error (string->symbol prog-name) "unrecognized command")))
      (let* ((file-name (car args))
             (hist-file-name (string-append file-name ".hist"))
             (version (if (null? (cdr args)) 0 (string->number (cadr args))))
             (comment (string-join #\space (cdr args)))
             (whoami (with-input-from-shell "whoami" (lambda () (read-line))))
             (date (with-input-from-shell "date" (lambda () (read-line)))))
        (cond ((string=? prog-name "put")
                (put file-name hist-file-name whoami date comment))
              ((string=? prog-name "get")
                (get file-name hist-file-name version))
              ((string=? prog-name "dir")
                (dir hist-file-name))
              (else (error (string->symbol prog-name) "unrecognized command"))))))


Create a new paste based on this one


Comments: