suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

does some quoted printable encodings

Browse Source 
svn: r6546
This commit is contained in:
Robby Findler 2007-06-08 14:49:56 +00:00
parent 63ce7b93fb
commit 860ee82a67
1 changed files with 57 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

67
collects/help/bug-report.ss
View File

@ -340,16 +340,19 @@
(define (get-query) (define (get-query)
(list (cons 'help-desk "true") (list (cons 'help-desk "true")
(cons 'replyto (preferences:get 'drscheme:email)) (cons 'replyto (preferences:get 'drscheme:email))
(cons 'originator (preferences:get 'drscheme:full-name)) (cons 'originator (qp-encode (preferences:get 'drscheme:full-name)))
(cons 'subject (send summary get-value)) (cons 'subject (qp-encode (send summary get-value)))
(cons 'severity (send severity get-string-selection)) (cons 'severity (qp-encode (send severity get-string-selection)))
(cons 'class (translate-class (send bug-class get-string-selection))) (cons 'class (translate-class (send bug-class get-string-selection)))
(cons 'release (send version get-value)) (cons 'release (qp-encode (send version get-value)))
(cons 'description (apply string-append (map (lambda (x) (string-append x "\n")) (cons 'description (qp-encode
(get-strings description)))) (apply string-append (map (lambda (x) (string-append x "\n"))
(cons 'how-to-repeat (apply string-append (map (lambda (x) (string-append x "\n")) (get-strings description)))))
(get-strings reproduce)))) (cons 'how-to-repeat (qp-encode
(cons 'platform (get-environment)))) (apply string-append
(map (lambda (x) (string-append x "\n"))
(get-strings reproduce)))))
(cons 'platform (qp-encode (get-environment)))))
(define (get-environment) (define (get-environment)
(string-append (send environment get-value) (string-append (send environment get-value)
@ -378,7 +381,7 @@
(string->url (format "http://~a:~a/cgi-bin/bug-report" (string->url (format "http://~a:~a/cgi-bin/bug-report"
bug-www-server bug-www-server
bug-www-server-port))] bug-www-server-port))]
[post-data [post-data
(parameterize ([current-alist-separator-mode 'amp]) (parameterize ([current-alist-separator-mode 'amp])
(string->bytes/utf-8 (alist->form-urlencoded query)))] (string->bytes/utf-8 (alist->form-urlencoded query)))]
[http-thread [http-thread
@ -421,6 +424,50 @@
(send response-abort enable #t) (send response-abort enable #t)
(switch-to-response-view))) (switch-to-response-view)))
;; qp-encode : string -> string
;; 'pre' escapes bytes that would be turned into non 7-bit values by utf8 encoding
;; so that later utf-8 encoding will just leave them alone .... (ugh)
;; also note that the encoding isn't quite quoted printable, since this code
;; cannot ensure that the entire bug report has short lines.
;; It doesn't do any soft line breaking, in fact.
(define (qp-encode str)
(bytes->string/utf-8 (qp-encode/bytes (string->bytes/utf-8 str))))
(define (qp-encode/bytes bytes)
(let loop ([blst (bytes->list bytes)]
[acc null])
(cond
[(null? blst) (list->bytes (reverse! acc))]
[else
(let ([b (car blst)])
(cond
[(<= 9 b 32)
(if (or (null? (cdr blst))
(not (equal? #\newline (cadr blst))))
(loop (cdr blst) (cons b acc))
(loop (cdr blst)
(add-qp-bytes b acc)))]
[(and (<= 33 b 126) (not (= b 61)))
(loop (cdr blst)
(cons b acc))]
[else
(loop (cdr blst)
(add-qp-bytes b acc))]))])))
(define (add-qp-bytes b acc)
(append (reverse (bytes->list (string->bytes/utf-8 (qp-encode/byte b))))
acc))
(define (qp-encode/byte b)
(format "=~a~a"
(hex-num->digit (quotient b 16))
(hex-num->digit (modulo b 16))))
(define (hex-num->digit d)
(cond
[(<= d 9) d]
[else (integer->char (+ (char->integer #\A) d -9))]))
(define (get-strings canvas) (define (get-strings canvas)
(let ([t (send canvas get-editor)]) (let ([t (send canvas get-editor)])
(let loop ([n 0]) (let loop ([n 0])