#!/homes/algebra/freundt/usr/local/guile/bin/guile -s
!#

(set! %load-path (cons "/homes/algebra/freundt/usr/local/guile/" %load-path))

(use-modules (srfi srfi-13))
(use-modules (ice-9 slib))
(use-modules (ice-9 regex))
(use-modules (ice-9 rw))

(define-public (url-decode str)
  ;; for efficiency reasons, we scan the string backwards, consing
  ;; a list of replacement characters as we go; any plus is replaced
  ;; by a space, and if a `%' is seen then the last two conses are
  ;; replaced by their hex-decoded equivalent.  A regex replace would
  ;; be conceptually cleaner, but less efficient, and it would require
  ;; invoking a closure for each hex decode.  Maybe scsh's funky
  ;; regex support would be helpful here!
  (let decode ((i      (1- (string-length str)))
               (chars '()))
    (if (< i 0)
        (apply string chars)
        (case (string-ref str i)
          ;; convert plusses
          ((#\+)  (decode (1- i) (cons #\space chars)))
          ;; hex-decode bytes
          ((#\%)  (let ((hi (car chars))
                        (lo (cadr chars)))
                    (decode (1- i) (cons (integer->char (hex->number hi lo))
                                         (cddr chars)))))
          ;; default: copy char verbatim
          (else   (decode (1- i) (cons (string-ref str i) chars)))))))

(define (hex->number hi lo)
  (+ (* 16 (hex-char->number hi))
     (hex-char->number lo)))

(define (hex-char->number ch)
  (if (char-alphabetic? ch)
      (+ 10
         (- (char->integer (char-upcase ch))
            (char->integer #\A)))
      (- (char->integer ch)
         (char->integer #\0))))

(define (myassoc-ref key alist)
  (let ((ent (assoc key alist)))
    (and ent (cdr ent))))


;; main vars
(define cgi-qenv (or (getenv "QUERY_STRING") ""))
(define cgi-script (or (getenv "SCRIPT_NAME") ""))
(define orderable #t)

(define cgi-qals (and cgi-qenv
                      (map (lambda (str)
                             (string-split str #\=))
                           (string-split cgi-qenv #\&))))

;; outpt format
(define output
  (let ((o (assoc "output" cgi-qals)))
    (if o (cadr o) "xml")))


;; read in the file as a single string
(define (file-contents file)
  (call-with-input-file file
    (lambda (p)
      (let* ((size (stat:size (stat p)))
             (buf (make-string size)))
        (read-string!/partial buf p)
        buf))))


(define (get-search-string)
  (url-decode
   (string-downcase (cadr (assoc "search" cgi-qals)))))

(define (record-filter-exact-condition searchstr)
  (string-append
   "translate("
   "signature/name,'ABCDEFGHIJKLMNOPQRSTUVWXYZ','abcdefghijklmnopqrstuvwxyz')"
   "='" searchstr "'"))

(define (record-filter-substring-condition searchstr)
  (string-append
   "contains("
   "translate("
   "signature/name,'ABCDEFGHIJKLMNOPQRSTUVWXYZ','abcdefghijklmnopqrstuvwxyz')"
   ",'" searchstr "')"
   " and "
   "not(" (record-filter-exact-condition searchstr) ")"))

(define (display-xml-head)
  (let* ((searchstr (get-search-string))
         (xmlsearch 
          (string-append
   "<?xml version=\"1.0\" encoding=\"utf-8\"?>
<xsl:stylesheet
  xmlns:xsl=\"http://www.w3.org/1999/XSL/Transform\"
  version=\"1.0\">

  <xsl:include href=\"" (or (getenv "STYLES") "") "/kd_berlin.xsl\"/>

  <xsl:output
    method=\"html\"
    encoding=\"iso-8859-1\"
    indent=\"yes\"
    standalone=\"yes\"/>

  <xsl:strip-space elements=\"inargs\"/>
  <xsl:preserve-space elements=\"shortdoc\"/>

  <xsl:template match=\"database\">
    <!-- Content: text/html -->
    <html>
      <head>
        <link rel='stylesheet' type='text/css' href='{$base.uri}/kash3.css'/>
        <link rel='shortcut icon' href='{$base.uri}/kantlogo/Zcrown/logo.Zcrown.16.png'/>
      </head>
      <body>
        <h3>Exact Matches</h3>
        <ul>
          <xsl:for-each
            select=\"record[" (record-filter-exact-condition searchstr) "]\">
            <li>
              <xsl:call-template name=\"MakeAnchoredSigFromHash\">
                <xsl:with-param name=\"hash\" select=\"@name\"/>
              </xsl:call-template>
            </li>
          </xsl:for-each>
        </ul>

        <h3>Substring Matches</h3>
        <ul>
          <xsl:for-each
            select=\"record[" (record-filter-substring-condition searchstr) "]\">
          <li>
            <xsl:call-template name=\"MakeAnchoredSigFromHash\">
              <xsl:with-param name=\"hash\" select=\"@name\"/>
            </xsl:call-template>
          </li>
        </xsl:for-each>
      </ul>

      </body>
    </html>
  </xsl:template>

</xsl:stylesheet>\n"
              )))
    xmlsearch))



(define (display-xml-nomatch)
  "No matches.")

(define (display-text-nomatch)
  "No matches.")

;; main control procedure alist
(define display-content-alist
  `(("xml"
     (type . "") ;;"<!-- Content: text/xslt -->\r\n\r\n")
     (head . ,#'display-xml-head)
     (nomatch . ,#'display-xml-nomatch))))



(define (display-content output)
  (display (myassoc-ref 'type (myassoc-ref output display-content-alist))))

(define (display-head output)
  (display ((or (myassoc-ref 'head (myassoc-ref output display-content-alist)) #'(lambda () "")))))

(define (display-foot output)
  (display ((or (myassoc-ref 'foot (myassoc-ref output display-content-alist)) #'(lambda () "")))))

(define (display-nomatch output)
  (display ((or (myassoc-ref 'nomatch (myassoc-ref output display-content-alist)) #'(lambda () "")))))



;;; main procedure

(display-content output)

(display-head output)





;; Local variables:
;; mode: scheme
;; End:
