123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151 |
- #!/usr/bin/env scheme-r7rs
- (import (scheme base)
- (scheme load)
- (scheme write)
- (scheme process-context)
- (scheme cxr)
- (scheme file)
- (macduffie cipher)
- (srfi 1))
- (define (usage)
- (display "Usage: ciphermytext [options] [-e] <algorithm> <plaintext/[-f=?]> <key>
- ciphermytext [options] -d <algorithm> <ciphertext/[-f=?]> <key>
- Algorithms:
- autokey
- caesar
- mono
- reptkey
- Options:
- -f=? Read from a file instead of an inline string.
- -h Display this help text.
- -i=? Set the number of iterations.
- -p Preserve the punctuation of the original message.
- -v Display the version of the software.\n")
- (exit))
- (define (version)
- (display "Version: 0.0.1\n")
- (exit))
- (define (extract-parameterized-arg args param-char default)
- (let loop ((list-out '())
- (list-in args))
- (if (null? list-in)
- (values args default)
- (let ((value (car list-in)))
- (if (and (char=? (string-ref value 0) #\-)
- (char=? (string-ref value 1) param-char))
- (if (not (char=? (string-ref value 2) #\=))
- (usage)
- (values (append (reverse list-out)
- (cdr list-in))
- (substring value 3 (string-length value))))
- (loop (cons value list-out) (cdr list-in)))))))
- (define (extract-iterations args)
- (define-values (a b) (extract-parameterized-arg args #\i "1"))
- (values a (string->number b)))
- (define (extract-file-type args)
- (extract-parameterized-arg args #\f #f))
- (define (extract-mode args)
- (if (member "-d" args)
- (values (delete "-d" args)
- 'decipher)
- (values (if (member "-e" args)
- (delete "-e" args)
- args)
- 'encipher)))
- (define (extract-punct args)
- (if (member "-p" args)
- (values (delete "-p" args)
- #t)
- (values args #f)))
- (define (check-algorithm algo)
- (if (not (member (string->symbol algo) (map car algos)))
- (usage)))
- (define (check-undetected args file-type)
- (for-each (lambda (x)
- (if (char=? (string-ref x 0) #\-)
- (usage)))
- args)
- (if (not (or (and (not file-type)
- (= (length args) 3))
- (and file-type
- (= (length args) 2))))
- (usage)))
- (define algos
- `((autokey ,autokey-encipher ,autokey-decipher)
- (caesar ,caesar-encipher ,caesar-decipher)
- (mono ,mono-encipher ,mono-decipher)
- (reptkey ,reptkey-encipher ,reptkey-decipher)))
- (define (get-cipher-type algo mode)
- (if (eq? mode 'encipher)
- (cadr (assq (string->symbol algo) algos))
- (caddr (assq (string->symbol algo) algos))))
- (define (read-entire-file file-name)
- (define port-in
- ;; A single dash means read from stdin
- (if (string=? file-name "-")
- (current-input-port)
- (open-input-file file-name)))
- (let loop ((result '())
- (next-line (read-line port-in)))
- (if (string? next-line)
- (loop (cons "\n" (cons next-line result))
- (read-line port-in))
- (begin
- (close-port port-in)
- (apply string-append (reverse result))))))
- (define (xcipher algo text key mode iters punct)
- (define key-cast (if (equal? algo "caesar") (string->number key) key))
- (define (cipher-once current-text)
- (apply-cipher (get-cipher-type algo mode) punct current-text key-cast))
- (let loop ((i 0)
- (current-text text))
- (if (< i iters)
- (let ((a (cipher-once current-text)))
- (loop (+ i 1) a))
- current-text)))
- (define (main-prog args)
- (define-values (arg-iter iters)
- (extract-iterations args))
- (define-values (arg-file-type file-type)
- (extract-file-type arg-iter))
- (define-values (arg-mode cipher-mode)
- (extract-mode arg-file-type))
- (define-values (new-args punctuate)
- (extract-punct arg-mode))
- (if (< iters 1)
- (error "ciphermytext-cli" "Iterations must be at least 1."))
- (if (or (member "--help" new-args)
- (member "-h" new-args))
- (usage))
- (if (or (member "--version" new-args)
- (member "-v" new-args))
- (version))
- (check-undetected new-args file-type)
- (check-algorithm (car new-args))
- (let ((result (if file-type
- (xcipher (car new-args) (read-entire-file file-type) (cadr new-args) cipher-mode iters punctuate)
- (xcipher (car new-args) (cadr new-args) (caddr new-args) cipher-mode iters punctuate))))
- (display result)
- (unless (and punctuate file-type) (newline))))
- (main-prog (cdr (command-line)))
|