Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
8e3f9be1
Commit
8e3f9be1
authored
Dec 28, 2011
by
Dave Cooper
Browse files
getting closer to full test & build
parent
312e5cbf
Changes
3
Hide whitespace changes
Inline
Side-by-side
gdl/apps/yadd/source/assembly.lisp
View file @
8e3f9be1
...
...
@@ -81,10 +81,10 @@ This list defaults to standard internal and test packages"
(
%index-ht
(
let
((
ht
(
make-hash-table
:size
(
length
(
the
:symbols-for-index
)))))
(
dolist
(
pair
(
the
symbols-for-index
)
ht
)
(
let
((
symbol
(
intern
(
second
pair
)
(
if
(
typep
(
first
pair
)
'object-dokumentation-category-message
)
:keyword
(
the-object
(
first
pair
)
package
)))))
(
let
((
symbol
(
glisp:
intern
(
second
pair
)
(
if
(
typep
(
first
pair
)
'object-dokumentation-category-message
)
:keyword
(
the-object
(
first
pair
)
package
)))))
(
pushnew
(
first
pair
)
(
gethash
symbol
ht
))))))
(
index-array
(
let
((
array
(
make-array
(
list
(
hash-table-count
(
the
%index-ht
)))))
...
...
gdl/cl-lite/source/genworks.lisp
View file @
8e3f9be1
...
...
@@ -90,7 +90,7 @@
(
when
create?
(
ensure-directories-exist
folder
))))
(
defun
temporary-file
(
&key
(
extension
nil
)
create?
)
(
let
((
file
(
merge-pathnames
(
make-pathname
:name
(
gensym
)
(
let
((
file
(
merge-pathnames
(
make-pathname
:name
(
string
(
gensym
)
)
:type
extension
)
(
temporary-folder
))))
(
when
create?
...
...
gdl/gwl/source/crawler.lisp
View file @
8e3f9be1
...
...
@@ -19,12 +19,17 @@
;; <http://www.gnu.org/licenses/>.
;;
(
in-package
:gwl
)
;;
;; FLAG -- put this back for SBCL and others when we switch to cl-html-parse from Quicklisp.
;;
#+
allegro
(
in-package
:gwl
)
#+
allegro
(
setf
(
net.html.parser::tag-no-end
:button
)
nil
)
#+
allegro
(
defun
crawl
(
part
&key
(
host
"localhost"
)
(
port
9000
)
...
...
@@ -63,7 +68,7 @@ the files are written into \"/tmp/sites/\".
#+
allegro
(
defun
crawl-anchor
(
anchor
host
port
output-root
visited-urls
)
(
let
((
new-url
(
getf
(
rest
(
first
anchor
))
:href
)))
;;
...
...
@@ -80,7 +85,7 @@ the files are written into \"/tmp/sites/\".
))
(
crawl-url
new-url
host
port
output-root
visited-urls
))))
#+
allegro
(
defun
crawl-url
(
url
host
port
output-root
visited-urls
)
(
when
(
not
(
gethash
url
visited-urls
))
(
setf
(
gethash
url
visited-urls
)
t
)
...
...
@@ -114,6 +119,7 @@ the files are written into \"/tmp/sites/\".
(
with-open-file
(
out
output-path
:direction
:output
:if-exists
:supersede
:if-does-not-exist
:create
)
(
html-print
lhtml
out
)))))))
#+
allegro
(
defun
relativize-lhtml
(
lhtml
url
output-path
host
)
(
when
lhtml
(
mapcar
#'
(
lambda
(
element
)
...
...
@@ -158,6 +164,8 @@ the files are written into \"/tmp/sites/\".
element
))))
(
t
(
relativize-lhtml
element
url
output-path
host
))))
lhtml
)))
#+
allegro
(
defun
relativize-image-source
(
url
base
)
(
let
((
length
(
-
(
length
(
split
base
#\/
))
3
)))
(
cond
((
>
length
0
)
...
...
@@ -167,7 +175,8 @@ the files are written into \"/tmp/sites/\".
((
and
(
zerop
length
)
(
eql
(
aref
url
0
)
#\/
))
(
subseq
url
1
))
(
t
url
))))
#+
allegro
(
defun
relativize-url
(
url
base
)
(
if
(
or
(
not
(
eql
(
aref
url
0
)
#\/
))
(
<
(
length
url
)
8
)
...
...
@@ -199,7 +208,7 @@ the files are written into \"/tmp/sites/\".
(
make-list
parent-levels
:initial-element
"../"
)
url-list
))))))
#+
allegro
(
defun
copy-url
(
url
dest
)
(
with-open-file
(
out
dest
:direction
:output
:if-exists
:supersede
:element-type
'
(
unsigned-byte
8
))
(
write-sequence
(
net.aserve.client:do-http-request
url
:format
:binary
)
out
)))
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a 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