Commit c3c2ea67 authored by Dave Cooper's avatar Dave Cooper
Browse files

Re-activated Distributed Gendl (dGDL), including making it work across...

Re-activated Distributed Gendl (dGDL), including making it work across modern-mode and ANSI mode CLs.
parent bd927d7b
(:cl-fad :gdl-base :gdl-cl-lite :gdl-geom-base)
(:cl-fad ;;:gdl-base :gdl-cl-lite :gdl-geom-base
)
(asdf:defsystem #:gdl-build :description
"Auto-generated asdf defsys from Genworks GDL cl-lite."
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :serial t
:version "2011101800" :depends-on (:cl-fad :gdl-base :gdl-cl-lite :gdl-geom-base)
:components
((:file "source/package") (:file "source/genworks")
(asdf:defsystem #:gdl-build :description
"Auto-generated asdf defsys from Genworks GDL cl-lite."
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :serial t
:version "2012050300" :depends-on (:cl-fad)
:components
((:file "source/package") (:file "source/genworks")
(:file "source/app") (:file "source/distro")))
\ No newline at end of file
......@@ -22,6 +22,9 @@
(in-package :gdl-build)
(define-object app ()
:computed-slots ((hey-now "hey now"))
:input-slots
(("String. The name which will be used for your application's executable and dxl file.
Defaults to \"my-gdl-app\""
......
......@@ -4,7 +4,7 @@
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license "AGPL unless otherwise indicated" :serial t
:version "2012042700" :depends-on (:gdl-gwl-graphics)
:version "2012050200" :depends-on (:gdl-gwl-graphics)
:components
((:file "robot/source/package")
(:file "robot/source/assembly")
......@@ -16,6 +16,7 @@
(:file "newsite/source/configurator")
(:file "newsite/source/contact-us")
(:file "newsite/source/demos")
(:file "newsite/source/documentation")
(:file "newsite/source/explanations")
(:file "newsite/source/index")
(:file "newsite/source/language")
......
......@@ -30,7 +30,7 @@
:respondent self)
;;(services :type 'services)
(documentation :type 'documentation
(documentation :type 'documentation-and-educational
:respondent self)
(demos :type 'demos
......@@ -42,4 +42,5 @@
(language :type 'language
:respondent self)
))
\ No newline at end of file
(in-package :www.genworks.com)
(define-object documentation-and-educational (base-site-sheet)
:computed-slots
((title "Genworks International - Documentation")
(link-title "Documentation")
(right-section-inner-html
(with-cl-who-string ()
(:h2 "Documenation and Educational Resources")
(:h3 "Lecture and Tutorial Videos")
((:div :class "profile")
((:div :class "people")
(:h4 "G102: Gendl Quickstart")
(:p "Note: Slides are available " ((:a :href "http://www.genworks.com/downloads/training-g102/" :target "g102-slides") "here") ", "
"Exercise skeletons " ((:a :href "https://github.com/genworks/Genworks-GDL/blob/master/documentation/training/g102/examples/source/g102-exercises.lisp?raw=true" :target "gendl-code") "here") ", and "
"Sample code from the slides " ((:a :href "https://github.com/genworks/Genworks-GDL/blob/master/documentation/training/g102/examples/source/section-2-examples.lisp?raw=true" :target "gendl-code") "here") ".")
(:p "You can play all the G102 videos, one after another, using this "
((:a :href "http://www.youtube.com/playlist?list=PLCF84A1DE8098DCE2" :target "gdl-videos") "playlist") ".")
(:ol
(:li ((:a :href "http://www.youtube.com/watch?v=9QSzuBeYHPE&hd=1" :target "gdl-videos")
"Section 1: Introduction (3:34)"))
(:li ((:a :href "http://www.youtube.com/watch?v=z0jSK3RyVIM&hd=1" :target "gdl-videos")
"Section 2.1 - 2.3: Functions (4:20)"))
(:li ((:a :href "http://www.youtube.com/watch?v=AeYUr1AQH1Y&hd=1" :target "gdl-videos")
"Section 2.3 - 2.4: Defining Functions (4:14)"))
(:li ((:a :href "http://www.youtube.com/watch?v=-KpiRYODYJ0&hd=1" :target "gdl-videos")
"Section 2.4 - 2.5: Functions as Objects (3:57)"))
(:li ((:a :href "http://www.youtube.com/watch?v=qKbgzdvfjfE&hd=1" :target "gdl-videos")
"Section 2.6 - 2.8: Basic Syntax of define-object (4:36)"))
(:li ((:a :href "http://www.youtube.com/watch?v=syMKEtC_rVI&hd=1" :target "gdl-videos")
"Section 2.8 - 2.9: Making Objects and Sending Messages to them (3:35)"))
(:li ((:a :href "http://www.youtube.com/watch?v=DSQTeUMQ8Og&hd=1" :target "gdl-videos")
"Section 2.10: Exercise 1 Intro (3:29)"))
(:li ((:a :href "http://www.youtube.com/watch?v=ZuYOZ33PiDI&hd=1" :target "gdl-videos")
"Section 2.11: Child Objects (5:02)"))
(:li ((:a :href "http://www.youtube.com/watch?v=bIu_AywMMQU&hd=1" :target "gdl-videos")
"Section 2.12: Gendl Object Sequences (4:44)")))))
(:h3 "Manuals and Tutorials")
((:div :class "profile")
((:div :class "people")
(:h4 "Gendl full Documentaion")
(:p (:ul (:li ((:a :href "https://github.com/genworks/Genworks-GDL/blob/master/documentation/gdl-documentation.pdf?raw=true") "GDL Unified Documentation"))))))
))))
......@@ -2,3 +2,4 @@
(gwl:define-package :training-g102 (:use :slide-show) (:export #:assembly #:push!))
o
\ No newline at end of file
;;
;; Copyright 2002-2011 Genworks International and Genworks BV
;; Copyright 2002-2012 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
......
......@@ -171,10 +171,18 @@ values are a color indicator for the default foreground and background of graphi
(defparameter *error-on-reserved-words?* t)
(defparameter *compile-for-dgdl?* nil "Boolean. Determines whether
global methods are defined during compilation to allow calling any
message on a gdl remote-object. This functionality is not available
in the core GDL kernel and depends on additional web/networking
modules. Defaults to nil.")
#+nil
(defparameter *compile-for-dgdl?* t "Boolean. Determines whether
global methods are defined during compilation to allow calling any
message on a gdl remote-object. This functionality is not available
in the core GDL kernel and depends on additional web/networking
modules. Defaults to t.")
(defparameter *gs-path* nil)
......@@ -299,6 +299,7 @@ You have a dependency on caffeine. Your children are your dependants.
(defclass gdl-basis () () (:metaclass gdl-class))
(defclass gdl-remote () () (:metaclass gdl-class))
(defun to-double-float (num) (coerce num 'double-float))
(defun to-single-float (num) (coerce num 'single-float))
......
......@@ -741,6 +741,7 @@ instantiation.</li></ol>"
()
nil)
#+nil
(fetch-input
()
nil)
......
......@@ -21,6 +21,53 @@
(in-package :com.genworks.lisp)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defpackage :com.genworks.lisp
(:use :common-lisp)
(:shadow #:intern)
(:nicknames :glisp)
(:import-from #+allegro :mop #+lispworks :hcl #+sbcl :sb-mop
#:validate-superclass)
(:export #:*external-text-format*
#:*gdl-home*
#:*genworks-source-home*
#:basic-command-line-arguments
#:begin-redefinitions-ok
#:current-directory
#:define-constant
#:direct-superclasses
#:direct-superclass-names
#:display-startup-banner
#:end-redefinitions-ok
#:eql-specializer
#:featurep
#:gl-class-name
#:gl-method-specializers
#:hex-string-to-integer
#:intern
#:make-sans-value-equalp-hash-table
#:make-sans-value-hash-table
#:make-weak-hash-table
#:set-default-float-format
#:set-default-package
#:set-defpackage-behavior
#:set-local-compiler-tweaks
#:set-window-titles
#:system-home
#:upcase
#:w-o-interrupts
#:xref-off
#:xref-on
#:validate-superclass
#:without-package-variance-warnings)))
(defmacro without-package-variance-warnings (&body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(handler-bind (#+sbcl(sb-int:package-at-variance #'muffle-warning))
,@body)))
(glisp:without-package-variance-warnings
(defpackage :com.genworks.lisp
(:use :common-lisp)
......@@ -91,11 +138,11 @@ and \"..\" entries."
#+lispworks
(directory (merge-pathnames *wild-entry* pathspec)
:directories t
:link-transparency nil)
:directories t
:link-transparency nil)
#+sbcl
(directory (merge-pathnames *wild-entry* pathspec)
:resolve-symlinks nil))
:resolve-symlinks nil))
;;
......
......@@ -49,15 +49,18 @@
:arguments (string \"string\")
"
(read-safe-string (base64-decode-safe string)))
(let ((decoded-string (string-downcase (base64-decode-safe string))))
(read-safe-string decoded-string)))
(defun base64-decode-safe (string)
"String. Decodes a base64 string without need for trailing = signs into a decoded string.
:arguments (string \"string\")
"
(defun base64-decode-safe (string)
(let ((padding (make-string (mod (- 4 (mod (length string) 4)) 4) :initial-element #\=)))
(funcall glisp:*base64-decode-func*
(string-append (glisp:replace-regexp (glisp:replace-regexp string "-" "+") "_" "/") padding))))
......
......@@ -53,17 +53,24 @@
(with-http-body (req ent)
(let ((value (if object (multiple-value-bind (value error)
(ignore-errors
(apply (symbol-function (intern message :gdl-inputs))
object (intern part-name :gdl-acc) child args))
(if (typep error 'error)
(progn
(when *debug?* (error error))
(cond ((or (search "could not handle"
(format nil "~a" error))
(search "instances could handle"
(format nil "~a" error)))
'gdl-rule:%not-handled%)
(t (list :error (format nil "~a" error)))))
(apply (symbol-function (glisp:intern message :gdl-inputs))
object (glisp:intern part-name :gdl-acc) child args))
(if (typep error 'error)
(let ((error-string
(glisp:replace-regexp
(format nil "~a" error) "\\n" " ")))
(cond ((or (search "could not handle"
error-string)
#+nil
(search "which is the root"
error-string)
(search "instances could handle"
error-string))
'gdl-rule:%not-handled%)
(t (when *debug?*
(format t "Throwing error on fetch-input server because gwl::*debug?* is set to non-nil~%")
(error error))
(list :error (format nil "~a" error)))))
value))
(list :error :no-such-object (getf args-list :remote-id)))))
(let ((encoded-value (base64-encode-safe (format nil "~s" (encode-for-http value)))))
......@@ -97,6 +104,11 @@
(args (rest (assoc "args" query :test #'string-equal)))
(*ipaddr* (socket:ipaddr-to-dotted (socket:remote-host (request-socket req)))))
(let ((args-list (base64-decode-list args)))
(when *debug?*
(format t "~%In send-remote-message-object response func:~%")
(print-variables args-list))
(let ((*package* (or (find-package (getf args-list :package)) *package*)))
(let ((object (when (gethash (getf args-list :remote-id) *remote-objects-hash*)
(the-object (gethash (getf args-list :remote-id) *remote-objects-hash*)
......@@ -107,19 +119,20 @@
(with-http-response (req ent)
(with-http-body (req ent)
(let ((value (if object (multiple-value-bind (value error)
(glisp:w-o-interrupts
(ignore-errors (if args
(the-object object ((evaluate message)
(:apply args)))
(the-object object (evaluate message)))))
(if (typep error 'error)
(progn
(when *debug?* (error error))
(list :error (format nil "~a" error)))
value))
(list :error :no-such-object (getf args-list :remote-id)))))
(let ((encoded-value (base64-encode-safe (format nil "~s" (encode-for-http value)))))
(html (format *html-stream* encoded-value)))))))))))
......@@ -146,7 +159,7 @@
(with-http-body (req ent)
(let ((value
(with-output-to-string(*stream*)
(apply (intern message :gdl-output)
(apply (glisp:intern message :gdl-output)
*%format%* object t ;; flag pick up skin
args))))
(let ((encoded-value
......@@ -165,8 +178,13 @@
(ipaddr (socket:ipaddr-to-dotted (socket:remote-host (request-socket req))))
(*ipaddr* (socket:ipaddr-to-dotted (socket:remote-host (request-socket req))))
(args (rest (assoc "args" query :test #'string-equal))))
(let ((args-list (base64-decode-list args)))
(when *debug?*
(format t "~%In make-remote-object response func:~%")
(print-variables args-list))
(let ((*package* (or (find-package (getf args-list :package)) *package*))
(name (getf args-list :name))
(index (getf args-list :index))
......
......@@ -83,7 +83,13 @@
:package *package*)))))
(multiple-value-bind
(result length)
(read-safe-string
(base64-decode-list
(net.aserve.client:do-http-request (format nil "http://~a:~a/fetch-remote-input?args=~a"
(the host) (the port) encoded-args)))
#+nil
(read-safe-string
(base64-decode-safe
(net.aserve.client:do-http-request (format nil "http://~a:~a/fetch-remote-input?args=~a"
(the host) (the port) encoded-args))))
......@@ -121,19 +127,24 @@
:remote-id (the remote-id)
:remote-root-path (the remote-root-path)
:package *package*)))))
(multiple-value-bind
(result length)
(read-safe-string
(base64-decode-safe
(net.aserve.client:do-http-request (format nil "http://~a:~a/send-remote-message?args=~a"
(the host) (the port) encoded-args))))
(declare (ignore length))
;;
;; FLAG -- pass result through generic function to sanitize
;;
(let ((result (decode-from-http result)))
(cond ((and (consp result) (eql (first result) :error)
(eql (second result) :no-such-object))
(progn
......@@ -185,6 +196,9 @@
(defmethod encode-for-http ((item t)) item)
(defmethod encode-for-http ((item pathname))
(format nil "~a" item))
(defmethod encode-for-http ((item package))
(package-name item))
......@@ -231,7 +245,8 @@
:root-path (the-object item root-path)
:host :unknown
:port (slot-value (slot-value (symbol-value (read-from-string "net.aserve:*wserver*"))
(read-from-string "net.aserve::socket")) 'socket:local-port)))
(read-from-string "net.aserve::socket")) #+allegro 'socket:local-port
#-allegro 'acl-compat.socket::port)))
(defmethod print-object ((object remote-object) stream)
......
......@@ -22,5 +22,5 @@
(in-package :gwl)
(define-object vanilla-remote (vanilla-mixin* gdl-remote gdl-basis)
(define-object vanilla-remote (vanilla-mixin* gdl-remote gdl::gdl-basis)
:no-vanilla-mixin? t)
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