[cl-who-devel] Heap corruption?
John Thingstad
john.thingstad at chello.no
Fri Aug 3 20:11:33 UTC 2007
Below is a selection of code I have written and the output it generates.
The part that function generates a nested list of lists for a tree control.
My system runs under Huchentoot. I use Lispworks under Windows.
The output looks good.
I can run it approx 10 times in a row.
Then something fails.
Among the errors are:
1. MySQL: 2006 - connection lost
2. MySQL: "select * from blog-header where (id = 199)"
selector just be one row
3. The browser dons't update at all. When I go back other pages show
incorrect data.
I have isolated it to navigate-blog, navigate-year and navigate-month
functions.
I tried completly rewiting it (this is the second version), but get the
same problem.
Any idea what is happening here?
(defun remove-prefix (uri prefix)
"Returns the prefix from an uri in search of a blog name.
Big assumtion: Blog names consists only of latin characters."
(let ((scanstring (concatenate 'string prefix "([A-Za-z]+)")))
(multiple-value-bind (dummy matchvector)
(scan-to-strings scanstring uri)
(declare (ignore dummy))
(if matchvector
(svref matchvector 0)
""))))
(defconstant *month-abbrev*
(list "jan" "feb" "mar" "apr" "may" "jun"
"jul" "aug" "sep" "oct" "nov" "dec"))
(defun get-month-string (month)
(nth (decf month) *month-abbrev*))
(defun extract-year (date-string)
(parse-integer (subseq date-string 0 4)))
(defun extract-month (date-string)
(parse-integer (subseq date-string 5 7)))
;; Result format: ((year (month (date title url) ...) ...) ...)
(defun make-navigate-list (item-list name)
(let (last-year last-month year-list month-list result-list)
(iter (for item in (reverse item-list))
(let* ((date-string (getf item :pub_time))
(year (extract-year date-string))
(month (extract-month date-string)))
(when (or (not last-year)
(< year last-year))
(setf last-year year)
(setf last-month nil)
(when month-list (push (reverse month-list) year-list))
(setf month-list nil)
(when year-list (push (reverse year-list) result-list))
(setf year-list (list (format nil "~D" year))))
(when (or (not last-month)
(< month last-month))
(setf last-month month)
(when month-list (push (reverse month-list) year-list))
(setf month-list (list (get-month-string month))))
(push
(list
(subseq (getf item :pub_time) 0 10)
(or (getf item :title) "")
(format nil "~A?id=~D" name (getf item :id)))
month-list)))
(when month-list (push (reverse month-list) year-list))
(when year-list (push (reverse year-list) result-list))
(reverse result-list)))
(defun navigate-month (month-list)
(with-html-output-to-string
(*standard-output* nil :prologue nil :indent t)
(:li
(:a :href (format nil "/~A/" (first month-list))
(fmt "~A" (first month-list)))
(:ul
(iter (for item in (rest month-list))
(htm
(:li
(:a :href (third item)
(fmt "~A ~A" (first item) (second item))))))))))
(defun navigate-year (year-list)
(with-html-output-to-string
(*standard-output* nil :prologue nil :indent t)
(:li
(:a :href (format nil "/~A/" (first year-list))
(fmt "~A" (first year-list)))
(iter (for month-list in (rest year-list))
(htm
(:ul
(fmt "~A" (navigate-month month-list))))))))
(defun navigate-blog (items name)
(let ((navigate-list (make-navigate-list items name)))
(with-html-output-to-string
(*standard-output* nil :prologue nil :indent t)
(:div :id "bloglist"
(:ul :id "navigation" :class "foldertree"
(iter (for year-list in navigate-list)
(fmt "~A" (navigate-year year-list))))))))
(defun present-blog (blog)
(let* ((item-id (or (and (get-parameter "id")
(parse-integer (get-parameter "id")))
(latest-blog-item-id (getf blog :name))))
(item (get-blog-item item-id)))
(with-html-output-to-string
(*standard-output* nil :prologue t :indent t)
(:html :xmlns "http://www.w3.org/1999/xhtml"
(:head
(:title (fmt "~A - ~A"
(escape-string (getf blog :title))
(escape-string (getf item :title))))
(:link :href *blog-css-file*
:rel "stylesheet" :type "text/css")
(:link :href *tree-css-file*
:rel "stylesheet" :type "text/css"
:media "screen, projection")
(:script :type "text/javascript" :src *tree-js-file* ""))
(:body
(:div :id "left-column"
(:a :href *blog-homepage* "Blog home")
(fmt "~A" (navigate-blog (get-items (getf blog :id))
(script-name))))
(:div :id "wrapper"
(:div :id "header"
(:h1 (escape-string
(fmt "~A" (escape-string (getf blog :title))))))
(:div :id "main"
(if item
(htm
(:h3 (fmt "~A" (escape-string
(getf item :title))))
(:h4 (fmt "~A" (escape-string
(getf item :pub_time))))
(:p (fmt "~A" (or (getf item :contents) ""))))
(htm
(:p (:em "This blog is empty!")))))))))))
(defun no-blog ()
(with-html-output-to-string
(*standard-output* nil :prologue t :indent t)
(:html :xmlns "http://www.w3.org/1999/xhtml"
(:head
(:title "Error")
(:link :href *blog-css-file*
:rel "stylesheet" :type "text/css"))
(:body
(:div :id "left-column"
(:a :href *blog-homepage* "Blog home"))
(:div :id "wrapper"
(:div :id "header"
(:h1 :class "middle" "Error!"))
(:div :id "main"
(:h2 :class "middle" "No such page")
(:p :class "middle"
"The blog that you requested does not exist!")))))))
(defun blog-page ()
(no-cache)
(let ((blog (get-blog (remove-prefix (script-name) *blog-prefix*))))
(if blog
(present-blog blog)
(no-blog))))
;;-----------------------------------------------------------------------------------------------------------
Which generatates something like the following
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html xmlns='http://www.w3.org/1999/xhtml'>
<head>
<title>Many Items blog - Tomorrow
</title>
<link href='/static-files/stylesheet.css' rel='stylesheet'
type='text/css' />
<link href='/static-files/foldertree.css' rel='stylesheet'
type='text/css' media='screen, projection' />
<script type='text/javascript' src='/static-files/treeMenu.js'>
</script>
</head>
<body>
<div id='left-column'>
<a href='/blogs.html'>
Blog home
</a>
<div id='bloglist'>
<ul id='navigation' class='foldertree'>
<li>
<a href='/2007/'>2007
</a>
<ul>
<li>
<a href='/jul/'>jul
</a>
<ul>
<li>
<a href='/blogs/many?id=204'>2007-07-18 Tomorrow
</a>
</li>
<li>
<a href='/blogs/many?id=202'>2007-07-18 Tomorrow
</a>
</li>
<li>
<a href='/blogs/many?id=200'>2007-07-18 Tomorrow
</a>
</li>
<li>
<a href='/blogs/many?id=199'>2007-07-17 Today
</a>
</li>
<li>
<a href='/blogs/many?id=201'>2007-07-17 Today
</a>
</li>
<li>
<a href='/blogs/many?id=203'>2007-07-17 Today
</a>
</li>
<li>
<a href='/blogs/many?id=193'>2007-07-17 First item
</a>
</li>
</ul>
</li>
</ul>
<ul>
<li>
<a href='/jun/'>jun
</a>
<ul>
<li>
<a href='/blogs/many?id=198'>2007-06-12 Hollydays
</a>
</li>
<li>
<a href='/blogs/many?id=194'>2007-06-11 Second item
</a>
</li>
</ul>
</li>
</ul>
<ul>
<li>
<a href='/mar/'>mar
</a>
<ul>
<li>
<a href='/blogs/many?id=197'>2007-03-15 Easter
</a>
</li>
</ul>
</li>
</ul>
</li>
<li>
<a href='/2006/'>2006
</a>
<ul>
<li>
<a href='/dec/'>dec
</a>
<ul>
<li>
<a href='/blogs/many?id=195'>2006-12-24 Christmas
</a>
</li>
</ul>
</li>
</ul>
<ul>
<li>
<a href='/mar/'>mar
</a>
<ul>
<li>
<a href='/blogs/many?id=196'>2006-03-14 Easter
</a>
</li>
</ul>
</li>
</ul>
</li>
</ul>
</div>
</div>
<div id='wrapper'>
<div id='header'>
<h1>Many Items blog
</h1>
</div>
<div id='main'>
<h3>Tomorrow
</h3>
<h4>2007-07-18 00:00:00
</h4>
<p>
</p>
</div>
</div>
</body>
</html>
More information about the Cl-who-devel
mailing list