Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
1080076f
Commit
1080076f
authored
Mar 15, 2013
by
Dave Cooper
Browse files
Added experimental restoring of timed-out or missing sessions to gwlAjax.
parent
7cb0960d
Changes
4
Hide whitespace changes
Inline
Side-by-side
gendl.asd
View file @
1080076f
...
...
@@ -9,8 +9,8 @@
:depends-on
(
:gwl-graphics
:tasty
:robot
:yadd
)
:components
((
:file
"source/try"
)))
:yadd
)
)
...
...
geom-base/drawing/source/lenses.lisp
100755 → 100644
View file @
1080076f
...
...
@@ -279,7 +279,7 @@
(
let
((
command
(
format
nil
"\"~a\" -q -sDEVICE=~a \"-sOutputFile=~a\" -dTextAlphaBits=~a -dGraphicsAlphaBits=~a -dSAFER -dBATCH -dNOPAUSE \"~a\""
(
format
nil
"\"~a\" -q -sDEVICE=~a \"-sOutputFile=~a\" -dTextAlphaBits=~a -dGraphicsAlphaBits=~a -dSAFER -dBATCH -dNOPAUSE \"~a\""
*gs-path*
"jpeg"
temp-jpeg
*gs-text-alpha-bits*
*gs-graphics-alpha-bits*
temp-pdf
)))
(
glisp:run-gs
command
))
...
...
geom-base/prereqs/source/genworks.lisp
View file @
1080076f
...
...
@@ -73,8 +73,11 @@
(
defun
run-gs
(
command
)
"Shell out a ghostscript command and handle errors."
(
let
((
result
#+
(
and
mswindows
allegro
)
(
excl:run-shell-command
command
:show-window
:hide
)
#-
(
and
mswindows
allegro
)
(
run-program
command
:output
(
make-broadcast-stream
))))
;;#+(and mswindows allegro) (excl:run-shell-command command :show-window :hide)
;;#-(and mswindows allegro) (run-program command :output (make-broadcast-stream))
(
run-program
command
:output
(
make-broadcast-stream
))
))
(
unless
(
zerop
result
)
(
error
"Ghostscript threw error"
))))
(
defun
run-program
(
command
&key
output
ignore-error-status
force-shell
...
...
gwl/ajax/source/ajax.lisp
View file @
1080076f
...
...
@@ -22,6 +22,47 @@
(
in-package
:gwl
)
;;
;; FLAG -- Undocumented. This will change.
;;
(
defvar
*snap-folder*
(
or
(
probe-file
(
merge-pathnames
"snaps/"
"sys:"
))
(
ensure-directories-exist
(
merge-pathnames
"snaps/"
(
glisp:temporary-folder
)))))
(
defun
restore-from-snap
(
iid
)
(
let
((
new-self
(
let
((
snap-file
(
merge-pathnames
(
make-pathname
:name
(
format
nil
"~a"
iid
)
:type
"snap"
)
*snap-folder*
)))
(
when
(
probe-file
snap-file
)
(
with-error-handling
()
(
read-snapshot
:filename
snap-file
:keys-to-ignore
(
list
:time-last-touched
:time-instantiated
:expires-at
)))))))
(
when
new-self
(
setf
(
gethash
(
make-keyword
(
the-object
new-self
instance-id
))
*instance-hash-table*
)
(
list
new-self
nil
))
(
when
(
typep
new-self
'session-control-mixin
)
(
the-object
new-self
set-expires-at
))
(
the-object
new-self
set-instantiation-time!
)
(
the-object
new-self
set-time-last-touched!
)
;;(evaluate-relevant-slots new-self)
(
format
t
"~%~%*************** Session ~a Restarted! ***************~%~%"
(
the-object
new-self
instance-id
))
(
the-object
new-self
tree-manager
restore-design-state!
))
;;
;; FLAG for testing only.
;; return error object instead of just throwing an error here.
;;
(
unless
new-self
(
error
"Restoring of session ~a was not possible.~%"
iid
))
new-self
))
(
defun
gdlAjax
(
req
ent
)
(
let*
((
query-plist
(
gwl::assoc-list-to-plist
(
request-query
req
)))
...
...
@@ -46,6 +87,15 @@
(
raw-fields
(
getf
query-plist
:|raw-fields|
))
(
iid
(
getf
plist
:|iid|
))
(
self
(
first
(
gethash
(
make-keyword
iid
)
gwl:*instance-hash-table*
)))
;;
;; Restore from snapshot if exists.
;;
(
self
(
or
self
(
restore-from-snap
iid
)))
;;
;; FLAG If not exists, we don't handle that yet.
;;
(
plist
(
decode-from-ajax
plist
self
))
(
bashee
(
getf
plist
:|bashee|
))
(
respondent
(
progn
(
when
*debug?*
(
print-variables
plist
))
...
...
@@ -87,12 +137,20 @@
(
when
(
and
respondent
(
the-object
respondent
root
)
(
the-object
respondent
root
(
set-remote-host!
req
))))
(
quick-save
self
)
(
respond-with-new-html-sections
req
ent
respondent
))))
(
publish
:path
"/gdlAjax"
:function
'gdlAjax
)
(
defun
quick-save
(
self
&key
(
snap-folder
*snap-folder*
))
(
let
((
snap-file
(
merge-pathnames
(
make-pathname
:name
(
format
nil
"~a"
(
the
instance-id
))
:type
"snap"
)
snap-folder
)))
(
the
(
write-snapshot
:filename
snap-file
))))
(
defun
wrap-cdata
(
string
)
...
...
@@ -181,17 +239,3 @@ You can reload to get previous state" *ajax-timeout*))
#+
nil
(
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
))
#+
nil
(
publish
:path
"/ajaxJSON"
:function
'ajaxJSON
)
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment