Commit 6c41940b authored by Dave Cooper's avatar Dave Cooper
Browse files

Fixed Issue 45, Issue 44, updated base64 functions to handle utf-8 encodings.

parent 5d2f4b5b
o Try to replace some formatting images with CSS3 (e.g. rounded corners)
o [self contribution] Look further into wind demo, try to fix smlib bug.
o Replace robot with primi-plane with some controls.
o Update the available options in Configurator -- brainstorm for new
product combinations and creative pricing options.
o Fix the restarting bug in the server.
......@@ -177,3 +177,21 @@ You can reload to get previous state" *ajax-timeout*))
(let ((result string))
(dolist (substring substrings result)
(setq result (replace-substring result substring "")))))
(defun ajaxJSON (req ent)
(format t "At 1~%")
(let ((query-plist (gwl::assoc-list-to-plist (request-query req))))
(print-variables query-plist))
(respond-with-nothing req ent))
(publish :path "/ajaxJSON" :function 'ajaxJSON)
......@@ -282,6 +282,35 @@ checkbox-form-control."
(the (gdl-ajax-call (:apply (append (list :asynch? nil) args)))))
(&key (bashee (the bashee))
(respondent (the respondent))
(asynch? t))
(declare (ignore form-controls))
(let ((json-string (json:encode-json-to-string
(append (list :|iid| (the-object respondent instance-id)
:|bashee| bashee)
(unless (eql respondent bashee)
(list :|respondent| respondent))
(when function-key
(list :|function| function-key))
(when arguments
(list :|arguments| arguments)))))))
(declare (ignore json-string))
;; FLAG - build up the call to gdlAjaxJSON
(format nil "ajaxJSON(event, 'foo=合影', ~a)" (if asynch? "true" "false"))))
......@@ -316,6 +345,9 @@ running the Javascript interpreter to evaluate (the js-to-eval), if any.
;; FLAG -- Breaks for utf-8 characters e.g. Chinese. Rewrite this entire scheme to use cl-json!!
;; FLAG -- holding off on move to cl-json for now, replaced
;; base64-utils with utf-8-capable versions.
(&key (bashee (the bashee))
(respondent (the respondent))
......@@ -390,6 +422,12 @@ running the Javascript interpreter to evaluate (the js-to-eval), if any.
(string-3 (if asynch? "true" "false")))
(when *debug?* (print-variables string-1 string-2 string-3))
(setq string-1 (glisp:replace-regexp string-1 "\\" "\\\\\\\\")
string-2 (glisp:replace-regexp string-2 "\\" "\\\\\\\\"))
(if one-arg?
(format nil "gdlAjax1('args=~a~a);" string-1 string-2)
(format nil "gdlAjax(event,'args=~a~a,~a);" string-1 string-2 string-3)))
(:gdl-base :gdl-cl-lite :aserve :cl-pdf :cl-who :cl-ppcre :cl-base64 :trivial-backtrace :cl-html-parse)
#.(error "This has to be put in manually -- conditional includes here.)
(:gdl-base :gdl-cl-lite :aserve :cl-pdf :cl-who :cl-ppcre #-allegro :cl-base64 #-allegro :babel :trivial-backtrace :cl-html-parse)
......@@ -6,7 +6,8 @@
:license "AGPL unless otherwise indicated" :serial t
:version "2012101100" :depends-on
(:gdl-base :gdl-cl-lite :aserve :cl-pdf :cl-who
:cl-ppcre :cl-base64 :trivial-backtrace
:cl-ppcre #-allegro :cl-base64 #-allegro :babel
((:file "source/package") (:file "source/genworks")
......@@ -174,7 +174,6 @@ instance at what time should the recovery instance expire?"
(let ((fe-processor (make-object 'form-element-processor
:bashee bashee
:query-plist query-plist)))
......@@ -191,7 +190,7 @@ instance at what time should the recovery instance expire?"
;;(when *debug?* (print-variables *query-plist* rest-plist rest-keys))
;;(when *debug?* (setq *f-e-p* fe-processor))
(when *debug?* (setq *f-e-p* fe-processor))
(dolist (key rest-keys)
(when (gethash (make-keyword-sensitive key) settables)
......@@ -23,6 +23,7 @@
(in-package :gwl)
(defmethod encode-for-ajax ((item t)) item)
(defmethod encode-for-ajax ((item list))
......@@ -65,7 +65,7 @@ by user application code.")
(defun assoc-list-to-plist (assoc-list &key case-sensitive?)
(mapcan #'(lambda(cons)
(list (if case-sensitive? (make-keyword-sensitive (first cons))
(make-keyword-sensitive (first cons)))
(make-keyword-sensitive (first cons)))
(rest cons)))
......@@ -38,9 +38,11 @@
(let ((cl-ppcre:*allow-quoting* t))
(glisp:replace-regexp (funcall glisp:*base64-encode-func* string) "=" "")
"\\Q+\\E" "-") "/" "_")))
(glisp:replace-regexp (funcall glisp:*base64-encode-func* string) "=" "")
"\\Q+\\E" "-") "/" "_") "\\n" "") "\\r" "")))
(defun base64-decode-list (string)
......@@ -49,7 +51,11 @@
:arguments (string \"string\")
(let ((decoded-string (string-downcase (base64-decode-safe string))))
;; FLAG -- removed string-downcase for the decoded-string. Watch for this; don't know
;; why it was there in the first place.
(let ((decoded-string (base64-decode-safe string)))
(read-safe-string decoded-string)))
......@@ -4,7 +4,8 @@
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:nicknames :glisp)
(:export #:*base64-encode-func*
(:export #:*enable-utf8?*
......@@ -21,12 +22,42 @@
(defparameter *base64-encode-func*
(defparameter *base64-decode-func*
(defparameter *enable-utf8?* t)
(defparameter *base64-encode-func*
#+allegro #'(lambda(string)
(excl:string-to-base64-string string :external-format (if *enable-utf8?* :utf-8 :default)))
(if *enable-utf8?*
(babel:string-to-octets string :encoding :utf-8))
(cl-base64:string-to-base64-string string))))
(defparameter *base64-decode-func*
(excl:base64-string-to-string string :external-format (if *enable-utf8?* :utf-8 :default)))
(if *enable-utf8?*
(cl-base64:base64-string-to-usb8-array string) :encoding :utf-8)
(cl-base64:base64-string-to-string string))))
(defun class-slots (class)
#-(or allegro lispworks sbcl ccl) (error "Need implementation for class-slots for currently running lisp.~%")
(#+allegro mop:class-slots
......@@ -231,12 +262,12 @@ the \"current\" error."
(destructuring-bind (free used)
(glisp:split-regexp ":" cons)
(list (make-keyword (format nil "~a-free-cons" prefix)) (parse-integer free)
(make-keyword (format nil "~a-used-cons" prefix)) (parse-integer used)))
(list (gdl:make-keyword (format nil "~a-free-cons" prefix)) (parse-integer free)
(gdl:make-keyword (format nil "~a-used-cons" prefix)) (parse-integer used)))
(destructuring-bind (free used)
(glisp:split-regexp ":" other)
(list (make-keyword (format nil "~a-free-other" prefix)) (parse-integer free)
(make-keyword (format nil "~a-used-other" prefix)) (parse-integer used)))))))))))
(list (gdl:make-keyword (format nil "~a-free-other" prefix)) (parse-integer free)
(gdl:make-keyword (format nil "~a-used-other" prefix)) (parse-integer used)))))))))))
(defun slot-definition-name (slot-definition)
......@@ -250,8 +250,6 @@ function decode64(input) {
var enc1, enc2, enc3, enc4;
var i = 0;
// remove all characters that are not A-Z, a-z, 0-9, +, /, or =
//input = input.replace(/[^A-Za-z0-9\+\/\=]/g, "");
input = input.replace(/[^A-Za-z0-9\-\_\=]/g, '');
while (i < input.length) {
......@@ -292,8 +290,11 @@ function collectMenuSelections(select)
for (var i = 0; i < select.options.length; i++)
if (select.options[i].selected)
items = items + ':|' + + '| ' + doublequote + encode64(select.options[i].value) + doublequote + ' ';
//items = items + ':|' + + '| ' + doublequote + select.options[i].value + doublequote + ' ';
if (items)
return(':|' + | '|' + doublequote + encode64('nil') + doublequote + ' ');
......@@ -305,3 +306,5 @@ function loadScript(url){
;; Copyright 2002, 2012 Genworks International
;; This source file is part of the General-purpose Declarative
;; (roLanguage project (GDL).
;; This source file contains free software: you can redistribute it
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; Affero General Public License for more details.
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <>.
(in-package :gwl-lift-tests)
(define-object large-data (base-ajax-sheet)
((array-element-value (the array-element value))
(array-size-value (the array-size value))
(large-array (make-array (the array-size-value) :initial-element (the array-element-value)))
(sum (progn (sleep 1) (reduce #'+ (the large-array))))
(html-sections (list (the main-section)))
(main-sheet-body (with-cl-who-string ()
(str (the main-section main-div)))))
((main-section :type 'sheet-section
:inner-html (with-cl-who-string ()
(:p (str (the development-links)))
(:p ((:span :id "gdlStatus") "Done."))
(:p (str (the sum)))
(:p (:fieldset (str (the array-element html-string))
(str (the array-size html-string))))))
(array-element :type 'number-form-control
:size 8
:prompt "Value for Array Element"
:ajax-submit-on-change? t
:default 10)
(array-size :type 'number-form-control
:size 8
:prompt "Value for Array Element"
:ajax-submit-on-change? t
:default 10000)
(publish-gwl-app "/large-data" 'large-data)
\ No newline at end of file
(in-package :gwl-user)
(define-object ajax-json-test (base-ajax-sheet)
((use-jquery? t)
(main-sheet-body (with-cl-who-string ()
(str (the Main-Section main-div)))))
((Main-Section :type 'sheet-section
:inner-html (with-cl-who-string ()
(str (the development-links))
(str (the Application-Domain html-string))
"Current value: " (str (the Application-Domain value))
(str (the send form-control-string))))
(Application-Domain :type 'text-form-control
:size 35
:maxlength 30
:allow-nil? t
:default "Engineering")
(send :type 'button-form-control
:label "Send"
:onclick ;;(the (ajax-json.js :form-controls (list (the Application-Domain))))
(the (gdl-ajax-call :form-controls (list (the Application-Domain)))))))
(publish-gwl-app "/ajt" 'ajax-json-test)
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment