;;;;;; Email address crippler -*- Scheme -*- ;;;;;; Munging email addresses so as not to be found by spammers ;;; Taylor Campbell wrote this code; he places it in the public domain. ;;; This depends on Taylor Campbell's string-replace.scm, a library for ;;; multiple parallel string replacements, which in turn depends on his ;;; string-collector.scm, a library for collecting strings. ;;; Note: This file does *not* contain Scheme code. It contains code ;;; in the Scheme48 configuration language; load it into the config ;;; package of scsh. (It depends on some scsh stuff, too.) I may at ;;; some point make this code more portable. (define-interface crippling-addresses-interface (export cripple-address char-encode-string char-encode-string/element punctuate-email-address)) (define-structure crippling-addresses crippling-addresses-interface (open scheme-with-scsh let-opt char-set-lib ;; Simpler than regexps. (STRING-REPLACING corresponds with ;; string-replace.scm.) string-replacing ;; This could use SRFI 6, but, since STRING-REPLACING already ;; requires that the string collector library be loaded, and ;; this removes an extra dependency, we might as well use this. ;; (STRING-COLLECTORS is in string-collector.scm.) string-collectors) (optimize auto-integrate) (begin ;;; (CHAR-ENCODE-STRING ) ;;; Encodes each character in STRING as an SGML character entity ;;; reference if it's in CHAR-SET, and surrounds each character, ;;; regardless of whether or not it gets encoded, with LEFT-PAD ;;; and RIGHT-PAD. (define (char-encode-string s cset left-pad right-pad) (let ((collector (make-string-collector))) (let* ((emit (lambda (ch) (cond ((char-set-contains? cset ch) (collect-string! collector "&#") (collect-string! collector (number->string (char->ascii ch) 10)) (collect-char! collector #\;)) (else (collect-char! collector ch))))) (emit (cond ((and left-pad right-pad) (lambda (ch) (collect-string! collector left-pad) (emit ch) (collect-string! collector right-pad))) (left-pad (lambda (ch) (collect-string! collector left-pad) (emit ch))) (right-pad (lambda (ch) (emit ch) (collect-string! collector right-pad))) (else emit))) (len (string-length s))) (do ((i 0 (+ i 1))) ((= i len) (string-collector->string collector)) (emit (string-ref s i)))))) ;;; Convenience for wrapping it in an SGML element. (define (char-encode-string/element s cset tag) (char-encode-string s cset (string-append "<" tag ">") (string-append ""))) ;;; (PUNCTUATE-EMAIL-ADDRESS
;;; [ ]) -> string ;;; Replaces the at-signs and dots in an email address. (define (punctuate-email-address address . args) (let-optionals args ((new-at " (at) ") (new-dot " (dot) ") (old-at "@") (old-dot ".")) (strings-replace address (list (cons old-at new-at) (cons old-dot new-dot)) char=?))) ; Should this be CHAR-CI=? ? ;;; (CRIPPLE-ADDRESS
) ;;; -> string ;;; Does all the crippling: CRIPPLE-ADDRESS ;;; - encodes ADDRESS into SGML character references; ;;; - surrounds each character with CHAR-TAG SGML elements; ;;; - cripples the punctuation of the address; and ;;; - surrounds the crippled punctuation with PUNCTUATION-TAG ;;; SGML elements. (define (cripple-address address char-tag punctuation-tag) (punctuate-email-address (char-encode-string/element (punctuate-email-address address) char-set:ascii ; ... char-tag) ;; New at & dot: surround them in a punctuation element. (string-append " <" punctuation-tag ">" (char-encode-string/element "(at)" char-set:ascii char-tag) " ") (string-append " <" punctuation-tag ">" (char-encode-string/element "(dot)" char-set:ascii char-tag) " ") ;; Old at & dot: they're surrounded in the regular character ;; element. (char-encode-string/element " (at) " char-set:ascii char-tag) (char-encode-string/element " (dot) " char-set:ascii char-tag))) )) ; (define-structure crippling-addresses