;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File - urlpath.lisp
;; Description - Guts of MSc ex 1
;; Author - Tim Bradshaw (tfb at lostwithiel)
;; Created On - Tue Feb 1 23:16:51 2000
;; Last Modified On - Mon Jun 25 12:57:03 2001
;; Last Modified By - Gail Anderson (ga at lostwithiel)
;; Update Count - 23
;; Status - Unknown
;;
;; $Id: urlpath.lisp,v 1.1 2003/01/23 22:19:15 colin Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (C) 2000, 2001 Cley Limited
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;; USA.
;;;
;;; You can contact Cley Limited by emailing cley@cley.com.
(in-package :upt)
;;;; Page descriptions
;;;
(defun map-page-descriptions (fn file) ;+++export
"Map FN for side-effect over all page descriptions in FILE. Return FILE"
(with-open-file (str file :direction :input)
(with-standard-io-syntax
(loop with eof = '#.(make-symbol "EOF")
for page = (read str nil eof)
until (eq page eof)
do (funcall fn page))))
file)
;;;; URLPATH tools
;;;
(defun merge-urlpath (urlpath default) ;+++export
"Merge a urlpath with a default path. Return merged path."
(make-urlpath :name (urlpath-name urlpath)
:directory (let ((upd (urlpath-directory urlpath))
(dpd (urlpath-directory default)))
(if (eql (first upd) ':relative)
(append dpd (rest upd))
upd))))
;;;; indexifying directories
;;;
(defvar *index-file-name* "index.html" ;+++export
"Default index file name")
(defun indexify-urlpath (urlpath
&optional (index-name *index-file-name*)) ;+++export
"Add the optional index name to a urlpath, if it had a null name component."
(or (urlpath-name urlpath) (setf (urlpath-name urlpath) index-name))
urlpath)
;;;; Pruning paths
;;;
(defun eliminate-backs (dirlist) ;+++export
"Eliminate the :BACK components from the *tail* of a directory list
(everything apart from the leading :ABSOLUTE / :RELATIVE).
Return pruned list."
(if (null dirlist)
'()
(let ((f (first dirlist))
(r (eliminate-backs (rest dirlist))))
(if (and (not (eql f ':back))
(eql (first r) ':back))
(rest r)
(cons f r)))))
(defun prune-directory (dir) ;+++export
"Given a full directory list, prune any :BACK components, being
smart about :ABSOLUTE and :RELATIVE directories. Return pruned
list."
(labels ((prune-leading (tail)
(if (eq (first tail) ':back)
(prune-leading (rest tail))
tail)))
(let ((type (first dir)))
(cons type
(if (eq type ':absolute)
(prune-leading (eliminate-backs (rest dir)))
(eliminate-backs (rest dir)))))))
(defun prune-urlpath (urlpath) ;+++export
"Prune the directory of a URLPATH, destructively. Return argument,
modified"
(setf (urlpath-directory urlpath)
(prune-directory (urlpath-directory urlpath)))
urlpath)
;;;; Canonicalising page descriptions
;;;
(defun canonicalize-link (urlpath &optional default) ;+++export
"given a link, canonicalize it by pruning it and, if DEFAULT is
given, merging with DEFAULT. Destructive (because PRUNE-URLPATH is).
Return the first argument, modified"
(prune-urlpath (indexify-urlpath
(if default
(merge-urlpath urlpath default)
urlpath))))
(defstruct page-attributes
;; +++exported + maker + accessors (not predicate, copier)
urlpath
links)
(defun page-description->page-attributes (description) ;+++export
"Take a page description and return a newly built bla ...";!!!FIXME
(let ((default (canonicalize-link
(path-name->urlpath (first description)))))
(make-page-attributes
:urlpath default
:links (mapcar #'(lambda (p)
(canonicalize-link (path-name->urlpath p)
default))
(rest description)))))
;;;; Trees
;;;
;;; This implementation uses CLOS, and has an (undocumented and
;;; unexported) internal protocol which allows easy extension. See
;;; hashy-urlpath.lisp for an example of such an extension.
(defgeneric upt-node-value (node) ;+++export
(:documentation
"Return the value of NODE.
Only valid for nodes for which UPT-FILE-NODE-P returns true.")
(:method (node)
(error "UPT-NODE-VALUE on ~S?" node)))
(defgeneric map-upt-node-children (fn node);+++export
(:documentation
"Map FN over the children of NODE for side-effect.
FN is called with 2 arguments: the name of the child and the child itself.
(This behaviour is similar to MAPHASH in CL).
Only valid for nodes for which UPT-DIR-NODE-P returns true.")
(:method (fn node)
(declare (ignore fn))
(error "MAP-UPT-NODE-CHILDREN on ~S?" node)))
(defgeneric find-upt-node-child (node string);++export
(:documentation
"Find the child of NODE whose name is STRING.
Return the child or NIL if it is not found.
Only valid for nodes for which UPT-DIR-NODE-P returns true.")
(:method
(node string)
(declare (ignore string))
(error "FIND-UPT-NODE-CHILD on ~S?" node)))
(defun store-urlpath (root path value) ;++export
"Store VALUE under the path PATH in tree ROOT.
An error is signalled unless PATH is a URLPATH whose directory is absolute
and which has a name (does not represent a directory).
An error is also signalled a directory already in the tree clashes with
the path being stored"
(unless (urlpath-p path)
(error "~S is not a URLPATH?" path))
(unless (eq (first (urlpath-directory path))
':absolute)
(error "Attempt to store a non-absolute path"))
(unless (urlpath-name path)
;; directories are not really user things
(error "Attempt to store a URLPATH which is a directory"))
(store-urlpath-loop root (rest (urlpath-directory path))
(urlpath-name path)
value)
value)
(defgeneric store-urlpath-loop (root ptail name value)
(:method
(root path ptail value)
(declare (ignore ptail value))
(error "STORE-URLPATH on ~S and ~S?" root path)))
(defgeneric upt-dir-node-p (node) ;+++export
(:method (node)
(declare (ignore node))
nil))
(defgeneric upt-file-node-p (node) ;+++export
(:method (node)
(declare (ignore node))
nil))
(defgeneric upt-dir-class-for-node (node)
;; Return the class of a directory for a child of NODE
(:method (node)
(class-of node)))
(defgeneric upt-file-class-for-node (node)
;; return the class of a file node for NODE
(:method (node)
(declare (ignore node))
(find-class 'upt-file-node)))
(defclass upt-node ()
())
(defclass upt-dir-node (upt-node)
((children-alist :initform '())))
(defmethod map-upt-node-children (fn (node upt-dir-node))
(dolist (c (slot-value node 'children-alist) node)
(funcall fn (car c) (cdr c))))
(defmethod find-upt-node-child ((node upt-dir-node) string)
(let ((found (assoc string (slot-value node 'children-alist)
:test #'equal)))
(if found (cdr found))))
(defmethod upt-dir-node-p ((node upt-dir-node))
t)
(defclass upt-file-node (upt-node)
((value :initform nil
:initarg :value
:reader upt-node-value)))
(defmethod upt-file-node-p ((node upt-file-node))
t)
(defvar *upt-type-map*
'((t . upt-dir-node)))
(defun make-upt (&key (representation t))
"Make and return an empty urlpath tree object."
(let ((match (cdr (assoc representation *upt-type-map*))))
(unless match
(error "Unknown representation ~S" representation))
(make-instance match)))
(defmethod store-urlpath-loop ((node upt-dir-node) tail
name value)
(with-slots (children-alist) node
(if (null tail)
(let ((found (assoc name children-alist :test #'equal)))
(if (null found)
(push (cons name (make-instance (upt-file-class-for-node node)
:value value))
children-alist)
(let ((val (cdr found)))
(when (not (upt-file-node-p val))
(error "Trying to store a file on a directory"))
(setf (slot-value val 'value) value))))
(store-urlpath-loop (or (cdr (assoc (first tail) children-alist
:test #'equal))
(let ((it (make-instance
(upt-dir-class-for-node node))))
(push (cons (first tail) it)
children-alist)
it))
(rest tail) name value))))
;;; storing pages into the tree
(defparameter *urlpath-tree* ;+++export
(make-upt)
"Default urlpath tree")
(defun store-all-page-descriptions (file &key
(tree *urlpath-tree*)) ;+++export
"Store PAGE-ATTRIBUTES objects corresponding to all the page descriptions
in FILE into TREE (default *URLPATH-TREE*). Return TREE."
(map-page-descriptions
#'(lambda (pd)
(let ((p (page-description->page-attributes pd)))
(store-urlpath tree (page-attributes-urlpath p)
p)))
file)
tree)
;;; finding nodes
(defun urlpath-value-in-upt (path root)
"Return the value stored under PATH in tree ROOT, or NIL if not found.
An error is signalled if: PATH is not a URLPATH; PATH's directory is not
absolute; PATH's name component is null.
If, when walking the tree, a directory node is found where there should be
a file node, a warning is given (with WARN) and NIL is returned.
Similarly, if a file node is found when there should be a directory node."
(unless (typep path 'urlpath)
(error "~S is not a URLPATH" path))
(unless (eq (first (urlpath-directory path)) ':absolute)
(error "~S is not absolute" path))
(unless (urlpath-name path)
(error "~S names a directory" path))
(labels ((uviu-loop (tail node name)
(if (null tail)
(let ((child (find-upt-node-child node name)))
(if child
(if (upt-dir-node-p child)
(progn
(warn "Found a dir node for a file")
nil)
(upt-node-value child))
nil))
(let ((next (find-upt-node-child node (first tail))))
(cond ((null next)
nil)
((upt-file-node-p next)
(warn "Found a file node for a dir")
nil)
(t
(uviu-loop (rest tail) next name)))))))
(uviu-loop (rest (urlpath-directory path)) root
(urlpath-name path))))
(defun map-upt-nodes (fn root) ;+++export
"Map FN for side-effect over all the name and nodes in ROOT.
FN is called with 2 arguments: the name of the node and the node itself.
The name of the root node is \"\"."
(labels ((mun (fn name node)
(funcall fn name node)
(when (upt-dir-node-p node)
(map-upt-node-children #'(lambda (nm nd)
(mun fn nm nd))
node))))
(mun fn "" root))
root)
(defun urlpath-dangling-links (path &key (tree *urlpath-tree*)) ;+++export
"Return a list of the dangling links (URLPATH objects) from PATH
in TREE (default *URLPATH-TREE*. An error is signalled is PATH is
not present in TREE"
(let ((found (urlpath-value-in-upt path tree)))
(unless found
(error "~S is not in ~S" path tree))
(page-attributes-dangling-links found tree)))
(defun page-attributes-dangling-links (pa tree)
(mapcan #'(lambda (path)
(if (not (urlpath-value-in-upt path tree))
(list path)
nil))
(page-attributes-links pa)))
(defun upt-dangling-links (&key (tree *urlpath-tree*)) ;+++export
"Return a list of the dangling links (URLPATH objects) for every file node
in TREE (default *URLPATH-TREE*."
(let ((danglers '()))
(map-upt-nodes #'(lambda (name node)
(declare (ignore name))
(when (upt-file-node-p node)
(dolist (l (page-attributes-dangling-links
(upt-node-value node)
tree))
(push l danglers))))
tree)
danglers))
(defun upt-dangling-path-names (&key (tree *urlpath-tree*))
"Return a list of the *names* of all the dangling links found in
TREE (default *URLPATH-TREE*)."
(mapcar #'urlpath->path-name
(upt-dangling-links :tree tree)))