Initial revision
authorTony Cook <tony@develop-help.com>
Tue, 8 May 2001 03:29:39 +0000 (03:29 +0000)
committertony <tony@45cb6cf1-00bc-42d2-bb5a-07f51df49f94>
Tue, 8 May 2001 03:29:39 +0000 (03:29 +0000)
40 files changed:
INSTALL.pod [new file with mode: 0644]
MANIFEST [new file with mode: 0644]
MANIFEST.SKIP [new file with mode: 0644]
Makefile [new file with mode: 0755]
README [new file with mode: 0755]
schema/bse.sql [new file with mode: 0644]
schema/data/article.txt [new file with mode: 0644]
schema/data/demoload.pl [new file with mode: 0644]
site/cgi-bin/admin/datadump.pl [new file with mode: 0755]
site/cgi-bin/admin/imageclean.pl [new file with mode: 0755]
site/cgi-bin/admin/makeIndex.pl [new file with mode: 0755]
site/cgi-bin/admin/move.pl [new file with mode: 0755]
site/cgi-bin/admin/shopadmin.pl [new file with mode: 0755]
site/cgi-bin/modules/AdminUtil.pm [new file with mode: 0644]
site/cgi-bin/modules/Article.pm [new file with mode: 0644]
site/cgi-bin/modules/Articles.pm [new file with mode: 0644]
site/cgi-bin/modules/DatabaseHandle.pm [new file with mode: 0644]
site/cgi-bin/modules/Generate/Product.pm [new file with mode: 0644]
site/cgi-bin/modules/Image.pm [new file with mode: 0644]
site/cgi-bin/modules/Images.pm [new file with mode: 0644]
site/cgi-bin/modules/Order.pm [new file with mode: 0644]
site/cgi-bin/modules/OrderItem.pm [new file with mode: 0644]
site/cgi-bin/modules/OrderItems.pm [new file with mode: 0644]
site/cgi-bin/modules/Orders.pm [new file with mode: 0644]
site/cgi-bin/modules/Product.pm [new file with mode: 0644]
site/cgi-bin/modules/Products.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/GPG.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/ImageEditor.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/PGP5.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/PGP6.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Row.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Table.pm [new file with mode: 0644]
site/cgi-bin/modules/Squirrel/Template.pm [new file with mode: 0644]
site/cgi-bin/search.pl [new file with mode: 0755]
site/cgi-bin/shop.pl [new file with mode: 0755]
site/data/stopwords.txt [new file with mode: 0644]
site/docs/bugs.pod [new file with mode: 0755]
site/docs/makedocs [new file with mode: 0644]
site/htdocs/css/admin.css [new file with mode: 0644]
site/htdocs/css/style-main.css [new file with mode: 0644]

diff --git a/INSTALL.pod b/INSTALL.pod
new file mode 100644 (file)
index 0000000..f498f23
--- /dev/null
@@ -0,0 +1,372 @@
+=head1 NAME
+
+   BSE installation guide.
+
+
+=head1 SYSTEM REQUIREMENTS
+
+=over 4
+
+=item *
+
+perl 5.005_03 or later
+
+=item *
+
+mysql 3.22. or later
+
+=item *
+
+GnuPG or PGP 5 or 6
+
+=item *
+
+a web host:
+
+=over 4
+
+=item *
+
+with telnet or ssh access
+
+=item *
+
+that runs your CGI scripts as your user
+
+=item *
+
+that runs your CGI scripts with the current working directory
+set to the directory that contains the CGI script.
+
+=back
+
+=back
+
+You will need at least the following Perl modules installed:
+
+=over 4
+
+=item *
+
+DBI
+
+=item *
+
+DBD::mysql
+
+=item *
+
+Digest::MD5
+
+=item *
+
+Apache::Session
+
+=back
+
+and their dependants.  If you use the CPAN shell to install these then
+the dependants will be installed automatically.
+
+All other modules are either supplied or standard with perl.
+
+I assume you know how to use a text editor, and have a basic knowledge
+of how directories work, and know enough perl to be able to edit
+constants.
+
+=head1 PLANNING
+
+You need to know:
+
+=over 4
+
+=item *
+
+the layout of directories on your web host: where CGI programs go
+(cgi-bin), where's the root of the document tree (htdocs), and where
+can you safely keep static data (datapath).  The names in parentheses
+() will be used in this documentation.
+
+=item *
+
+how you want your site to look, presumably as one or more HTML files
+and associated style sheets.
+
+=item *
+
+order processing information: the email address and public key of
+the user who will be receiving the order emails.  The email address
+and private key of the sender of the order emails (though this can be
+generated during installation.
+
+=back
+
+=head1 EXTRACT FILES
+
+Telnet or ssh to the web host.
+
+Extract the archive into a working directory:
+
+  mkdir work
+  cd work
+  tar xzf workpath/bse-0.04.tar.gz
+
+The directories in the archive are:
+
+  bse/                     Base directory
+  bse/schema               Database schema definitions (and some test data)
+  bse/site                 Laid out site
+  bse/site/htdocs          Document root
+  bse/site/cgi-bin         CGI programs
+  bse/site/templates       Sample page templates
+  bse/site/data            Static site data (currently just the stopwords list)
+  bse/site/docs            Documentation
+  bse/site/util            Utilities (currently just initial.pl)
+
+If you are running your own host, or have sufficient control over
+Apache, you may want to extract the archive in it's final directory
+and simply create a new <VirtualHost..> that uses the extracted
+directories.  If so, skip Copy Files.
+
+
+=head1 COPY FILES
+
+Replacing the names as decribed in L<PLANNING>
+
+  # the base documents
+  mkdir htdocs/admin
+  cp -R workpath/site/htdocs htdocs/
+  # page templates (you will need to modify these) and static data
+  mkdir datadir/templates
+  cp -R workpath/site/templates datadir/templates/
+  cp -R workpath/site/data datadir/
+  # cgi
+  cp -R workpath/site/cgi-bin cgi-bin/
+
+
+=head1 CONFIGURATION
+
+Most configuration information is kept in Constants.pm, which is in
+the cgi-bin/modules directory:
+
+  vi cgi-bin/modules/Constants.pm
+
+=head2 Database
+
+$DB should be the name of your mysql database.
+
+$UN and $PW should be your mysql login name and password.
+
+=head2 Directory structure
+
+If your directory structure matches that of the archive, this is
+simple, set $BASEDIR to point to the site directory.  The other
+variables are set based on that layout.
+
+Otherwise, set:
+
+=over 4
+
+=item $TMPLDIR
+
+to the directory you are keeping document templates in,
+'datapath/templates/' if you followed L<COPY FILES>
+
+=item $CONTENTBASE
+
+to the directory you are keeping the site document files in, 'htdocs/'
+if you followed L<COPY FILES>.
+
+=item $IMAGEDIR
+
+to the directory that image files are kept in.  This should be left as
+$CONTENTBASE . 'images/'
+
+=item $DATADIR
+
+to the directory containing F<stopwords.txt>
+
+=back
+
+B<Warning:> these paths I<must> be kept as absolute directories.  They
+must the directories as seen by the running CGI scripts.
+
+
+=head2 Site name
+
+You should set $URLBASE and $SECURLBASE to the URLs used to access
+your site in normal and SSL (https).  If you currently don't have secure access setup, you can use the same non-secure URL for both.
+
+B<Warning:> You I<must> set the $SECURLBASE to a secure URL and
+regenerate the site before accepting orders on the site.
+
+=head2 Level defaults
+
+This is probably the most complex item to configure.
+
+The %LEVEL_DEFAULTS hash describes how your site will look from the
+administration interface.  It has little effect on how the site looks
+from a user's perspective, except of course, that it sets defaults for
+some items.
+
+Each level of your site needs an entry in the hash, with the top level
+being 0 to indicate the whole site.  This top-level should only have
+the C<display> keyword defined.
+
+Each level except for level 0 should have the following keywords defined:
+
+=over 4
+
+=item *
+
+C<display> defines how the articles at this level is described when
+adding new articles.
+
+=item *
+
+C<template> is the default template name used for that level.  It
+should exist in the levels directory under your template directory.
+
+=item *
+
+C<threshold> is the default threshold used when a new article is
+created at that level.  Thresholds are used to control whether child
+article are rendered inline, or as summaries.
+
+=back
+
+=head2 Link Titles
+
+If you set $LINK_TITLES to non-zero, then the links created for the
+C<article link> and C<url article> tags will include the title as a
+translated suffix.  This allows some search engines to index on the
+URL as well as the content of the document. Without this suffix the
+url contains no useful indexable information.
+
+For this to work under Apache you will need the following in a
+.htaccess file in the htdocs/a directory:
+
+   RewriteEngine On
+   RewriteRule ^([0-9]+\.html)/[0-9a-zA-Z_]*$ ./$1 [T=text/html]
+
+=head2 Search options
+
+In geneal the search engine will generate a search index for all
+listed articles, and exclude unlisted articles.
+
+You have some control over the indexing.  Set @SEARCH_INCLUDE to the
+ids of sections that should be indexed, even if not listed.  Set
+@SEARCH_EXCLUDE to the ids of sections that should not be indexed.
+
+@SEARCH_EXCLUDE overrides @SEARCH_INCLUDE.
+
+Set $SEARCH_LEVEL to the lowest-level (highest number) of the articles
+to be indexed.  Lower level articles will still be indexed, but
+searches for them will find their parent article (or I<their> parent
+article, if it still isn't a low enough level.)
+
+$SEARCH_ALL is used as the name of the entry in the drop-down list of
+sections generated by the <:list:> tag on the search template.
+
+=head2 Deletion control
+
+Some articles are critical to the operation of your site.  If the
+article's id is in @NO_DELETE it cannot be deleted.
+
+=head2 The Shop
+
+This is probably the second hardest item to configure.
+
+It isn't necessary to configure this section until you need to use the
+shop.
+
+$SHOP_CRYPTO should be set to the supplied class that uses your
+installed encryption software.  Note that currently only Squirrel::GPG
+has been tested in production.  (Patches welcome on the other modules.)
+
+$SHOP_SIGNING_ID should be the user id of the key to use for signing
+orders.
+
+$SHOP_GPG, $SHOP_PGPE and $SHOP_PGP are the locations of the specified
+executables, for GunPG, PGP5 and PGP6 respectively.  They only need to
+be set if the executable isn't in the PATH when the shop.pl runs.
+
+$SHOP_SENDMAIL needs to be set to the name of sendmail or a compatible
+program.
+
+$SHOP_FROM will be used as the sender of the order emails.
+
+Processed, encrypted orders will be $SHOP_TO_NAME and $SHOP_TO_EMAIL.
+There must be a public key in the keyring, which has been signed by
+the private key $SHOP_SIGNING_ID (or whatever your default private
+signing key is.)
+
+You can set $SHOP_EMAIL_ORDER to 0 to prevent the order being emailed
+as above.  A confirmation email is still sent to the person who made
+the order.  This is only really for testing, since only the encrypted
+email contains the credit card number and expiry date.
+
+=head2 Maintenance Tools
+
+$DATA_EMAIL is the email address of a person that the 
+I<Dump database to email> page will send the MySQL database dump to.
+
+$MYSQLDUMP is the location of the MySQL C<mysqldump> tool.  If this
+isn't in the PATH you will need to add this here.
+
+=head1 DATABASE SETUP
+
+=head2 Schema load
+
+You need to install the database schema.  Presumably you have already
+created a user and database for the new site (or your host has.)
+
+To install the schema and the base data:
+
+  mysql -u youruserl -p yourdatabase <bse.sql
+
+You will be asked for your password.
+
+=head2 Base data load
+
+Change directory to the util directory in your workpath.
+
+If you moved the files you will need to edit initial.pl to change the line:
+
+  use lib '../cgi-bin/modules';
+
+so that it will specify the correct modules directory.
+
+You may want to simply set PERL5LIB to your new modules director instead:
+
+  PERL5LIB=cgi-bin/modules
+  export PERL5LIB
+
+Once you've done that, you can run initial.pl:
+
+  perl initial.pl
+
+B<Warning:> Do not run this after your site is up and has articles you
+want to keep.  This will delete all existing articles from your site.
+
+
+=head1 TEMPLATE SETUP
+
+See the site/docs/templates.pod (or .html).
+
+
+=head1 SECURITY
+
+Since your web host runs your CGI programs as you, you can make
+Constants.pm readble only by you.
+
+You will need to protect the htdocs/admin and cgi-bin/admin
+directories with .htaccess files.  For example:
+
+  AuthType Basic
+  AuthName "Administrator Only"
+  AuthUserFile "somepath/users.dat"
+  require valid-user
+
+The AuthUserFile needs to point to a file accessible by the user that
+the web server runs as.  So it won't work if you use your home
+directory.
diff --git a/MANIFEST b/MANIFEST
new file mode 100644 (file)
index 0000000..6ef0e88
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,139 @@
+INSTALL
+INSTALL.html
+INSTALL.pod
+Makefile
+MANIFEST
+MANIFEST.SKIP
+README
+# install.perl - not ready yet
+schema/article.txt
+schema/bse.sql
+schema/demoload.pl
+site/cgi-bin/admin/add.pl
+site/cgi-bin/admin/admin.pl
+site/cgi-bin/admin/datadump.pl
+site/cgi-bin/admin/generate.pl
+site/cgi-bin/admin/imageclean.pl
+site/cgi-bin/admin/makeIndex.pl
+site/cgi-bin/admin/move.pl
+site/cgi-bin/admin/shopadmin.pl
+site/cgi-bin/modules/AdminUtil.pm
+site/cgi-bin/modules/Article.pm
+site/cgi-bin/modules/Articles.pm
+site/cgi-bin/modules/Constants.pm
+site/cgi-bin/modules/Constants.tmpl
+site/cgi-bin/modules/DatabaseHandle.pm
+site/cgi-bin/modules/Generate.pm
+site/cgi-bin/modules/Generate/Article.pm
+site/cgi-bin/modules/Generate/Catalog.pm
+site/cgi-bin/modules/Generate/Product.pm
+site/cgi-bin/modules/Image.pm
+site/cgi-bin/modules/Images.pm
+site/cgi-bin/modules/Order.pm
+site/cgi-bin/modules/OrderItem.pm
+site/cgi-bin/modules/OrderItems.pm
+site/cgi-bin/modules/Orders.pm
+site/cgi-bin/modules/Product.pm
+site/cgi-bin/modules/Products.pm
+site/cgi-bin/modules/Squirrel/GPG.pm
+site/cgi-bin/modules/Squirrel/ImageEditor.pm
+site/cgi-bin/modules/Squirrel/PGP5.pm
+site/cgi-bin/modules/Squirrel/PGP6.pm
+site/cgi-bin/modules/Squirrel/Row.pm
+site/cgi-bin/modules/Squirrel/Table.pm
+site/cgi-bin/modules/Squirrel/Template.pm
+site/cgi-bin/modules/Util.pm
+site/cgi-bin/search.pl
+site/cgi-bin/shop.pl
+site/data/stopwords.txt
+site/docs/Generate.html
+site/docs/Generate::Article.html
+site/docs/Generate::Catalog.html
+site/docs/Generate::Product.html
+site/docs/Makefile
+site/docs/add.html
+site/docs/bse.html
+site/docs/bse.pod
+site/docs/bugs.html
+site/docs/bugs.pod
+site/docs/makedocs
+site/docs/search.html
+site/docs/shop.html
+site/docs/shopadmin.html
+site/docs/templates.html
+site/docs/templates.pod
+site/htdocs/a/.htaccess
+site/htdocs/admin/advanced.html
+site/htdocs/admin/index.html
+site/htdocs/css/admin.css
+site/htdocs/css/style-main.css
+site/htdocs/images/admin/move_down.gif
+site/htdocs/images/admin/move_up.gif
+site/htdocs/images/store/browse_more.gif
+site/htdocs/images/store/left_bottom_corner_line.gif
+site/htdocs/images/store/left_end_cap_solid.gif
+site/htdocs/images/store/price_cap.gif
+site/htdocs/images/store/right_bottom_corner_line.gif
+site/htdocs/images/store/right_end_cap_solid.gif
+site/htdocs/images/titles/advanced_search.gif
+site/htdocs/images/titles/java.gif
+site/htdocs/images/titles/perl.gif
+site/htdocs/images/titles/the_shop.gif
+site/htdocs/images/titles/your_site.gif
+site/htdocs/images/trans_pixel.gif
+site/htdocs/js/date.js
+site/htdocs/js/validate.js
+site/htdocs/shop
+site/templates/1/section.tmpl
+site/templates/1/section2.tmpl
+site/templates/1/shop_multicat.tmpl
+site/templates/1/sitemap.tmpl
+site/templates/2/menusubsect.tmpl
+site/templates/2/nosubsect.tmpl
+site/templates/2/subsection.tmpl
+site/templates/3/article.tmpl
+site/templates/4/response.tmpl
+site/templates/5/default.tmpl
+site/templates/add_product.tmpl
+site/templates/article_edit.tmpl
+site/templates/article_img.tmpl
+site/templates/base.tmpl
+site/templates/cart.tmpl
+site/templates/cart_base.tmpl
+site/templates/catalog.tmpl
+site/templates/catalog/multi.tmpl
+site/templates/checkout.tmpl
+site/templates/checkout_base.tmpl
+site/templates/checkoutfinal.tmpl
+site/templates/checkoutfinal_base.tmpl
+site/templates/common/index.tmpl
+site/templates/common/index2.tmpl
+site/templates/common/nosubsect.tmpl
+site/templates/common/section.tmpl
+site/templates/common/section2.tmpl
+site/templates/common/subsection.tmpl
+site/templates/edit_0.tmpl
+site/templates/edit_1.tmpl
+site/templates/edit_2.tmpl
+site/templates/edit_3.tmpl
+site/templates/edit_4.tmpl
+site/templates/edit_5.tmpl
+site/templates/edit_catalog.tmpl
+site/templates/edit_product.tmpl
+site/templates/extras.txt
+site/templates/index.tmpl
+site/templates/index2.tmpl
+site/templates/lowmap.tmpl
+site/templates/mailconfirm.tmpl
+site/templates/mailorder.tmpl
+site/templates/order_detail.tmpl
+site/templates/order_list.tmpl
+site/templates/product_detail.tmpl
+site/templates/product_list.tmpl
+site/templates/search.tmpl
+site/templates/search_base.tmpl
+site/templates/section_edit.tmpl
+site/templates/shop_help.tmpl
+site/templates/shop_sect.tmpl
+site/templates/shopitem.tmpl
+site/util/initial.pl
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
new file mode 100644 (file)
index 0000000..1098886
--- /dev/null
@@ -0,0 +1,2 @@
+.*,v
+.*~
diff --git a/Makefile b/Makefile
new file mode 100755 (executable)
index 0000000..a998cc1
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,53 @@
+VERSION=0.09adrian
+DISTNAME=bse-$(VERSION)
+DISTBUILD=$(DISTNAME)
+DISTTAR=../$(DISTNAME).tar
+DISTTGZ=$(DISTTAR).gz
+
+help:
+       @echo make dist - build the tar.gz file
+       @echo make clean - delete generated files
+
+# this target needs to be modified so that the output directory includes
+# the release number
+dist: $(DISTTGZ)
+
+$(DISTTGZ): distdir
+       if [ -e $(DISTTGZ) ] ; \
+         then echo $(DISTTGZ) already exists ; \
+              exit 1 ; \
+       fi
+       tar cf $(DISTTAR) $(DISTBUILD)
+       -rm -rf $(DISTBUILD)
+       gzip $(DISTTAR)
+
+#      tar czf $(DISTFILE) -C .. bse --exclude '*~' --exclude '*,v' --exclude 'pod2html-*cache'
+
+distdir:
+       -rm -rf $(DISTBUILD)
+       perl -MExtUtils::Manifest=manicopy,maniread -e "manicopy(maniread(), '$(DISTBUILD)')"
+
+clean:
+       -rm site/htdocs/index.html
+       -rm site/htdocs/shop/*.html
+       -rm site/htdocs/a/*.html
+       -cd site/htdocs/images ; \
+       for i in *.gif ; do \
+         if [ $$i != trans_pixel.gif ] ; then \
+           rm $$i ; \
+         fi ; \
+       done
+       -rm site/htdocs/images/*.jpg
+       -rm -rf $DISTBUILD
+
+docs: INSTALL INSTALL.html otherdocs
+
+INSTALL: INSTALL.pod
+       pod2text <INSTALL.pod >INSTALL
+
+INSTALL.html: INSTALL.pod
+       pod2html --infile=INSTALL.pod --outfile=INSTALL.html
+       -rm pod2html-dircache pod2html-itemcache
+
+otherdocs:
+       cd site/docs ; make all
diff --git a/README b/README
new file mode 100755 (executable)
index 0000000..0b59707
--- /dev/null
+++ b/README
@@ -0,0 +1,22 @@
+BSE
+===
+
+BSE is an engine for presenting a simple portal site with an attached
+store.
+
+The current feature set includes:
+
+- all articles are kept in a mysql database
+- data/actions are kept separate from presentation
+- a simple store with encrypted email to the administrator on order 
+  processing
+
+No, BSE doesn't stand for bovine spongiform encephalopathy.  Not here,
+anyway.
+
+For version information please see site/docs/bse.pod
+
+Installation documentation can be found in INSTALL.* and plenty of
+other documentation can be found in site/docs/
+
+Tony Cook <tony@develop-help.com>
diff --git a/schema/bse.sql b/schema/bse.sql
new file mode 100644 (file)
index 0000000..25cbae3
--- /dev/null
@@ -0,0 +1,188 @@
+-- represents sections, articles
+
+CREATE TABLE article (
+  id integer DEFAULT '0' NOT NULL auto_increment,
+
+  -- 0 for the entry page
+  -- -1 for top-level sections (shown in side menu)
+  parentid integer DEFAULT '0' NOT NULL,
+
+  -- the order to display articles in
+  -- used for ordering sibling articles
+  displayOrder integer not NULL default 0,
+  title varchar(64) DEFAULT '' NOT NULL,
+  titleImage varchar(64) not null,
+  body text NOT NULL,
+
+  -- thumbnail image
+  thumbImage varchar(64) not null default '',
+  thumbWidth integer not null,
+  thumbHeight integer not null,
+
+  -- position of first image for this article
+  imagePos char(2) not null,
+  release datetime DEFAULT '0000-00-00 00:00:00' NOT NULL,
+  expire datetime DEFAULT '9999-12-31 23:59:59' NOT NULL,
+  keyword varchar(255),
+
+  -- the template in $TMPLDIR used to generate this as HTML
+  template varchar(127) DEFAULT '' NOT NULL,
+
+  -- a link to the page generated for this article
+  -- if this is blank then no page is generated
+  -- this is combined with the base of the site to get the file
+  -- written to during generation
+  link varchar(64) not null,
+  admin varchar(64) not null,
+
+  -- if there are more child articles than this, display links/summaries
+  -- if the same of fewer, embed the articles
+  -- the template can ignore this
+  threshold integer not null default 3,
+
+  -- the length of summary to display for this article
+  summaryLength smallint(5) unsigned DEFAULT '200' NOT NULL,
+
+  -- the class whose generate() method generates the page
+  generator varchar(20) not null default 'article',
+
+  -- the level of the article, 1 for top-level
+  level smallint not null,
+
+  -- for listed:
+  -- 0 - don't list
+  -- 1 - list everywhere
+  -- 2 - list in sections, but not on the menu
+  listed smallint not null default 1,
+  -- date last modified
+  lastModified date not null,
+  PRIMARY KEY (id),
+
+  -- if we keep id in the indexes MySQL will sometimes be able to
+  -- perform a query using _just_ the index, without scanning through
+  -- all our main records with their blobs
+  -- Unfortunately MySQL can only do this on fixed-width columns
+  -- other databases may not need the id in the index, and may also be
+  -- able to handle the variable length columns in the index
+  INDEX article_date_index (release,expire, id),
+  INDEX article_displayOrder_index (displayOrder),
+  INDEX article_parentId_index (parentId),
+  INDEX article_level_index (level, id)
+);
+
+#
+# Table structure for table 'searchindex'
+#
+CREATE TABLE searchindex (
+  id varchar(200) binary DEFAULT '' NOT NULL,
+  -- a comma-separated lists of article and section ids
+  articleIds varchar(255) default '' not null,
+  sectionIds varchar(255) default '' not null,
+  scores varchar(255) default '' not null,
+  PRIMARY KEY (id)
+);
+
+#
+# Table structure for table 'image'
+#
+CREATE TABLE image (
+  id mediumint(8) unsigned NOT NULL auto_increment,
+  articleId integer not null,
+  image varchar(64) DEFAULT '' NOT NULL,
+  alt varchar(255) DEFAULT '[Image]' NOT NULL,
+  width smallint(5) unsigned,
+  height smallint(5) unsigned,
+  PRIMARY KEY (id)
+);
+
+# used for session tracking with Apache::Session::MySQL
+CREATE TABLE sessions (
+  id char(32) not null primary key,
+  a_session text,
+  -- so we can age this table
+  whenChanged timestamp
+);
+
+-- these share data with the article table
+create table product (
+  -- fkey to article id
+  articleId integer not null,
+
+  summary varchar(255) not null,
+
+  -- number of days it typically takes to supply this item
+  leadTime integer not null default 0,
+
+  -- prices are in cents
+  retailPrice integer not null,
+  wholesalePrice integer,
+
+  -- amount of GST on this item
+  gst integer not null,
+  
+  primary key(articleId)
+);
+
+-- order is a reserved word
+-- I couldn't think of/find another word here
+create table orders (
+  id integer not null auto_increment,
+
+  -- delivery address
+  delivFirstName varchar(127) not null default '',
+  delivLastName varchar(127) not null default '',
+  delivStreet varchar(127) not null default '',
+  delivSuburb varchar(127) not null default '',
+  delivState varchar(40) not null default '',
+  delivPostCode varchar(40) not null default '',
+  delivCountry varchar(127) not null default 'Australia',
+
+  -- billing address
+  billFirstName varchar(127) not null default '',
+  billLastName varchar(127) not null default '',
+  billStreet varchar(127) not null default '',
+  billSuburb varchar(127) not null default '',
+  billState varchar(40) not null default '',
+  billPostCode varchar(40) not null default '',
+  billCountry varchar(127) not null default 'Australia',
+
+  telephone varchar(80) not null default '',
+  facsimile varchar(80) not null default '',
+  emailAddress varchar(255) not null default '',
+  
+  -- total price
+  total integer not null,      
+  wholesaleTotal integer not null default 0,
+  gst integer not null,
+  
+  orderDate datetime not null,
+  
+  -- credit card information
+  ccNumberHash varchar(127) not null default '',
+  ccName varchar(127) not null default '',
+  ccExpiryHash varchar(127) not null default '',
+  ccType varchar(30) not null,
+
+  primary key (id),
+  index order_cchash(ccNumberHash)
+);
+
+create table order_item (
+  id integer not null auto_increment,
+  -- foreign key to product
+  productId integer not null,
+
+  -- foreign key to order
+  orderId integer not null,
+  
+  -- how many :)
+  units integer not null,
+
+  -- unit prices
+  price integer not null,
+  wholesalePrice integer not null,
+  gst integer not null,
+
+  primary key (id),
+  index order_item_order(orderId, id)
+);
diff --git a/schema/data/article.txt b/schema/data/article.txt
new file mode 100644 (file)
index 0000000..b4090ce
--- /dev/null
@@ -0,0 +1,16 @@
+id;parentid;displayOrder;title;titleImage;body;imagePos;release;expire;keyword;template;link;admin;threshold;summaryLength;generator;level;listed
+1;-1;0;What's Hot;/images/ss/whats_hot.gif;;tr;1900/00/00 00:00;9999/01/01 00:00;home;index.tmpl;/index.html;/cgi-bin/admin/admin.pl?id=1;100000;0;Generate::Article;1;0
+2;-1;6000;the scoop on...;/images/ss/scoop_on.gif;;tr;1900/00/00 00:00;9999/01/01 00:00;scoop;section.tmpl;/a/2.html/scoop;/cgi-bin/admin/admin.pl?id=2;0;200;Generate::Article;1;1
+3;-1;7000;events / seminars;/images/ss/events_seminars.gif;;tr;1900/01/01 00:00;9999/01/01 00:00;events,seminars;section2.tmpl;/a/3.html;/cgi-bin/admin/admin.pl?id=3;1000;200;Generate::Article;1;1
+4;-1;5000;bodyScoop Q&A;/images/ss/bodyscoop_QA.gif;;tr;1900/01/01 00:00;9999/01/01 00:00;questions,answers;section.tmpl;/a/4.html/questions_answers;/cgi-bin/admin/admin.pl?id=4;0;200;Generate::Article;1;1
+5;-1;4000;message boards;/images/ss/message_boards.gif;;tr;1900/01/01 00:00;9999/01/01 00:00;message,chat,forums;section.tmpl;/m/message.shtml;/cgi-bin/admin/admin.pl?id=5;5000;5000;Generate::Article;1;1
+6;-1;3000;on-line store;/images/ss/the_store.gif;;tr;1900/01/01 00:00;9999/01/01 00:00;shopping;shop.tmpl;/shop/shop.shtml;/cgi-bin/admin/shop.pl;5000;5000;Generate::Article;1;1
+7;-1;2000;bodyScoop media;/images/ss/bodyscoop_media.gif;;tr;1900/01/01 00:00;9999/01/01 00:00;media,press,release;section2.tmpl;/a/7.html;/cgi-bin/admin/admin.pl?id=7;10000;5000;Generate::Article;1;1
+8;-1;1000;about bodyScoop;/images/ss/about_bodyscoop.gif;;tr;1900/01/01 00:00;9999/01/01 00:00;about;section.tmpl;/a/8.html;/cgi-bin/admin/admin.pl?id=8;0;200;Generate::Article;1;1
+9;1;1;[what's hot];;;tr;1900/01/01 00:00;9999/01/01 00:00;;nosubsect.tmpl;;/cgi-bin/admin/admin.pl?id=1;1000;1000;Generate::Article;2;2
+10;3;1;[events];;;tr;1900/01/01 00:00;9999/01/01 00:00;;nosubsect.tmpl;;/cgi-bin/admin/admin.pl?id=3;3;200;Generate::Article;2;2
+11;7;1;[media];;;tr;1900/01/01 00:00;9999/01/01 00:00;;nosubsect.tmpl;;/cgi-bin/admin/admin.pl?id=7;3;200;Generate::Article;2;2
+12;2;4000;slimming products;;Get the lowdown on the latest slimming treatments. Find out what works and what doesn't. We evaluate the latest pills, potions, lotions and gadgets.;tr;1900/00/00 00:00;9999/01/01 00:00;;subsection.tmpl;/a/12.html;/cgi-bin/admin/admin.pl?id=12;2;100;Generate::Article;2;1
+13;2;3000;diet books;;Looking for a book about eating or exercise? We put the the good, the bad and the ugly.;tr;1900/00/00 00:00;9999/01/01 00:00;;subsection.tmpl;/a/13.html;/cgi-bin/admin/admin.pl?id=13;2;100;Generate::Article;2;1
+14;2;2000;weight loss programs;;Before you join a weight loss program, find out what's behind the offer.;tr;1900/00/00 00:00;9999/01/01 00:00;;subsection.tmpl;/a/14.html;/cgi-bin/admin/admin.pl?id=14;2;100;Generate::Article;2;1
+15;2;1000;excercise equipment;;Before you spend money to get fit, find out how exercise machines work and if they're worth your money.;tr;1900/00/00 00:00;9999/01/01 00:00;;subsection.tmpl;/a/15.html;/cgi-bin/admin/admin.pl?id=15;2;100;Generate::Article;2;1
diff --git a/schema/data/demoload.pl b/schema/data/demoload.pl
new file mode 100644 (file)
index 0000000..c142012
--- /dev/null
@@ -0,0 +1,43 @@
+#!/usr/bin/perl -w
+use strict;
+use DBI;
+
+my $dbh = DBI->connect('dbi:mysql:bodyscoop', 'root', '')
+  or die "Cannot connect to database: $DBI::errstr";
+
+my @tables = qw(article);
+
+for my $tbl (@tables) {
+  print "Table $tbl\n";
+  open IN, "< $tbl.txt" or die "Cannot open $tbl.txt: $!";
+  while (<IN>) {
+    last if /^[^#]/;
+  }
+  chomp;
+  my @columns = split /;/;
+  $dbh->do("delete from $tbl")
+    or die "Cannot delete from $tbl: $DBI::errstr";
+  my $sql = "insert into $tbl (".join(",", @columns).") values (".
+    join(",", ("?")x@columns).")";
+  my $sth2 = $dbh->prepare($sql)
+    or die "Cannot prepare $sql: $DBI::errstr";
+  while (<IN>) {
+    last if /^\s*$/;
+    #print "$tbl: $_\n";
+    if (/^[^#]/) {
+      chomp;
+      my @data = split /;/, $_, -1;
+      if (@data != @columns) {
+       print "Columns mismatch line $.:\n";
+       for my $index (0..$#columns) {
+         print "$columns[$index]: ", defined $data[$index] ? $data[$index] : "<undef>", "\n";
+       }
+      }
+      $sth2->execute(@data)
+       or die "Cannot execute $sql: $DBI::errstr";
+    }
+  }
+  close IN;
+}
+
+$dbh->disconnect;
diff --git a/site/cgi-bin/admin/datadump.pl b/site/cgi-bin/admin/datadump.pl
new file mode 100755 (executable)
index 0000000..54cb4fc
--- /dev/null
@@ -0,0 +1,85 @@
+#!/usr/bin/perl
+use lib '../modules';
+use Constants qw($UN $PW $DB $SHOP_SENDMAIL $SHOP_FROM $URLBASE $DATA_EMAIL
+                 $MYSQLDUMP);
+
+my $email = $DATA_EMAIL;
+my $opts = '-t';
+my $dumper = $MYSQLDUMP;
+$|=1;
+print "Content-Type: text/plain\n\n";
+my $user = $UN;
+my $pass = $PW;
+my $data = $DB;
+for ($user, $pass, $data) {
+  s/(["\\`\$])/\\$1/;
+}
+my $cmd = qq!$dumper "-u$user" "-p$pass" "$data"!;
+open DUMP, "$cmd 2>&1 |"
+  or do { print "Cannot open mysqldump: $!\n"; exit };
+
+# redirect to /dev/null so that the server sees STDOUT close
+# as soon as possible
+open EMAIL, "| $SHOP_SENDMAIL $opts >/dev/null"
+  or do { print "Cannot open sendmail: $!\n"; exit };
+my $boundary = "============_".time."_==========";
+print EMAIL <<EOS;
+To: $email
+From: $SHOP_FROM
+Content-Type: multipart/mixed;
+    boundary="$boundary"
+MIME-Version: 1.0
+
+This is a multipart message in MIME format
+
+--$boundary
+Content-Type: text/plain
+
+This message contains a database dump of the BSE site $URLBASE.
+
+If you did not request this dump you may want to change the 
+administration password for your site.
+
+--$boundary
+Content-Type: text/plain
+Content-Disposition: attachment; filename=bsedump.txt
+
+EOS
+while (<DUMP>) {
+print EMAIL;
+}
+print EMAIL <<EOS;
+--$boundary--
+
+EOS
+unless (close EMAIL) {
+  print "There may have been a problem sending the email, please check the error log\n";
+}
+unless (close DUMP) {
+  print "There may have been a problem retrieving the dump, please check the error log\n";
+}
+print "Database dump for $URLBASE sent to $email\n";
+
+__END__
+
+=head1 NAME
+
+  datadump.pl - dumps a mysql database and emails the result
+
+=head1 SYNOPSIS
+
+ (run as a CGI script)
+
+=head1 DESCRIPTION
+
+Emails a copy of the results of mysqldump as an attachment to the user
+specified by $DATA_EMAIL in Constants.pm.
+
+This is pretty quick and dirty code, so YMMV.  Please report bugs
+anyway.
+
+=head1 AUTHOR
+
+Tony Cook <tony@develop-help.com> at the prodding of Adrian Oldham.
+
+=cut
diff --git a/site/cgi-bin/admin/imageclean.pl b/site/cgi-bin/admin/imageclean.pl
new file mode 100755 (executable)
index 0000000..bf0cc31
--- /dev/null
@@ -0,0 +1,108 @@
+#!/usr/bin/perl -w
+use strict;
+use lib '../modules';
+use Images;
+use Articles;
+use Constants qw($IMAGEDIR);
+
+my %articleIds;
+my $images = Images->new;
+my @images = $images->all;
+
+++$|;
+print <<EOS;
+Content-Type: text/plain
+
+Image Cleanup Tool
+------------------
+
+Removing image records that have no article
+EOS
+
+# first remove any image records that don't have a valid article id
+for my $image (@images) {
+  print ".";
+  # do we know about this article id?
+  unless (exists $articleIds{$image->{articleId}}) {
+    $articleIds{$image->{articleId}} = 
+      defined(Articles->getByPkey($image->{articleId}));
+  }
+  unless ($articleIds{$image->{articleId}}) {
+    $image->remove();
+    print "x";
+  }
+}
+
+print "\n\nRebuilding image list and indexing\n";
+# rebuild the images list
+$images = Images->new;
+@images= $images->all;
+
+my %names = map { $_->{image}, $_->{id} } @images;
+
+print "\nRemoving unused images\n";
+
+opendir IMG, $IMAGEDIR
+  or do { print "Cannot open $IMAGEDIR: $!\n"; exit };
+while (defined(my $file = readdir IMG)) {
+  if ($file =~ /^\d{8}/) {
+    print ".";
+    unless ($names{$file} || !-f "$IMAGEDIR$file") {
+      print "x";
+      
+      unlink $IMAGEDIR.$file
+       or print "\nCould not remove $IMAGEDIR$file: $!\n";
+    }
+  }
+}
+
+print "\nDone\n";
+
+__END__
+
+=head1 NAME
+
+imageclean.pl - clean up the images directory and image records
+
+=head1 SYNOPSIS
+
+ (called as a CGI script, no values passed in)
+
+=head1 WARNING
+
+This will remove B<any> images in $IMAGEDIR that have names starting
+with 8 or more digits if they don't exist in the C<image> table as a
+record with a current article number.
+
+If you need image names of this form, put them elsewhere, or
+reconfigure $IMAGEDIR.
+
+=head1 DESCRIPTION
+
+Scans the C<image> table looking for images that don't have an
+article, and for image files that don't have image records.
+
+The first is required due to a bug in older versions that left the
+image records around when deleting an article.  It's also a recovery
+tool just in case the database loses referential integrity, since
+MySQL doesn't enforce it.
+
+The second is required for two reasons:
+
+=over
+
+=item
+
+older versions didn't remove the image files when images were removed
+
+=item
+
+you may have deleted articles with images under an older version, which would have left the image records (and the image files)
+
+=back
+
+=head1 AUTHOR
+
+Tony Cook <tony@develop-help.com>
+
+=cut
diff --git a/site/cgi-bin/admin/makeIndex.pl b/site/cgi-bin/admin/makeIndex.pl
new file mode 100755 (executable)
index 0000000..44c958f
--- /dev/null
@@ -0,0 +1,142 @@
+#!/usr/bin/perl -w
+use strict;
+use lib '../modules';
+use Articles;
+use Constants qw($BASEDIR $MAXPHRASE $URLBASE $DATADIR @SEARCH_EXCLUDE @SEARCH_INCLUDE $SEARCH_LEVEL);
+use DatabaseHandle;
+my $in_cgi = exists $ENV{REQUEST_METHOD};
+if ($in_cgi) {
+  eval "use CGI::Carp qw(fatalsToBrowser)";
+}
+
+my $stopwords = "$DATADIR/stopwords.txt";
+
+# load the stop words
+open STOP, "< $stopwords"
+  or die "Cannot open $stopwords: $!";
+chomp(my @stopwords = <STOP>);
+tr/\r//d for @stopwords; # just in case
+my %stopwords;
+@stopwords{@stopwords} = (1) x @stopwords;
+close STOP;
+
+my $articles = Articles->new;
+
+# scores depending on where the term appears
+# these may need some tuning
+# preferably, keep these to single digits
+my %scores =
+  (
+   title=>5,
+   body=>3,
+   keyword=>4,
+  );
+
+# if the level of the article is higher than this, store it's parentid 
+# instead
+my $max_level = $SEARCH_LEVEL;
+
+# key is phrase, value is hashref with $id -> $sectionid
+my %index;
+makeIndex($articles);
+
+#use Data::Dumper;
+#print Dumper(\%index);
+
+my $dh = DatabaseHandle->single;
+my $dropIndex = $dh->{dropIndex}
+  or die "No dropIndex member in DatabaseHandle";
+my $insertIndex = $dh->{insertIndex}
+  or die "No insertIndex member in DatabaseHandle";
+
+$dropIndex->execute()
+  or die "Could not drop search index ",$dropIndex->errstr;
+
+for my $key (sort keys %index) {
+  my $word = $index{$key};
+  # sort by reverse score so that if we overflow the field we
+  # get the highest scoring matches
+  my @ids = sort { $word->{$b}[1] <=> $word->{$a}[1] } keys %$word;
+  my @sections = map { $_->[0] } @$word{@ids};
+  my @scores = map { $_->[1] } @$word{@ids};
+  #my @sections = map { $_->[0] } values %{$index{$key}};
+  #my @scores = map { $_->[1] } values %{$index{$key}};
+
+  $insertIndex->execute($key, "@ids", "@sections", "@scores")
+    or die "Cannot insert into index: ", $insertIndex->errstr;
+}
+
+if ($in_cgi) {
+  print "Refresh: 0; url=\"$URLBASE/admin/\"\n";
+  print "Content-Type: text/html\n\n<html></html>\n";
+}
+
+sub makeIndex {
+  my $articles = shift;
+  my %dont_search;
+  my %do_search;
+  @dont_search{@SEARCH_EXCLUDE} = @SEARCH_EXCLUDE;
+  @do_search{@SEARCH_INCLUDE} = @SEARCH_INCLUDE;
+  until ($articles->EOF) {
+    # find the section
+    my $article = $articles->getNext;
+    my $section = $article;
+    while ($section->{parentid} >= 1) {
+      $section = $articles->getByPkey($section->{parentid});
+    }
+    my $id = $article->{id};
+    my $indexas = $article->{level} > $max_level ? $article->{parentid} : $id;
+    my $sectionid = $section->{id};
+    eval "use $article->{generator}";
+    $@ and die $@;
+    my $gen = $article->{generator}->new;
+    next unless $gen->visible($article) or $do_search{$sectionid};
+    
+    next if $dont_search{$sectionid};
+
+    for my $field (sort { $scores{$b} <=> $scores{$a} } keys %scores) {
+      # strip out markup
+      my $text = $article->{$field};
+      next if $text =~ m!^\<html\>!i; # I don't know how to do this (yet)
+      $text =~ s/[abi]\[([^\]]+)\]/$1/g if $field eq 'body';
+
+      # for each paragraph
+      for my $para (split /\n/, $text) {
+       my @words = split /\W+/, $para;
+       my @buffer;
+
+       for my $word (@words) {
+         if ($stopwords{lc $word}) {
+           process($indexas, $sectionid, $scores{$field}, @buffer) if @buffer;
+           @buffer = ();
+         }
+         else {
+           push(@buffer, $word);
+         }
+       }
+       process($indexas, $sectionid, $scores{$field}, @buffer) if @buffer;
+      }
+    }
+  }
+}
+
+sub process {
+  my ($id, $sectionid, $score, @words) = @_;
+  
+  for (my $start = 0; $start < @words; ++$start) {
+    my $end = $start + $MAXPHRASE-1;
+    $end = $#words if $end > $#words;
+    
+    for my $phrase (map { "@words[$start..$_]" } $start..$end) {
+      if (!exists $index{lc $phrase}{$id}
+         || $score > $index{lc $phrase}{$id}[1]) {
+       $index{lc $phrase}{$id} = [ $sectionid, $score ];
+      }
+      if (!exists $index{$phrase}{$id}
+         || $score > $index{$phrase}{$id}[1]) {
+       $index{$phrase}{$id} = [ $sectionid, $score ];
+      }
+    }
+  }
+}
+
diff --git a/site/cgi-bin/admin/move.pl b/site/cgi-bin/admin/move.pl
new file mode 100755 (executable)
index 0000000..d544113
--- /dev/null
@@ -0,0 +1,76 @@
+#!/usr/bin/perl -w
+
+# reorders the article then refreshes back to the parent
+
+use strict;
+use lib '../modules';
+use Articles;
+use CGI ':standard';
+use Carp 'verbose';
+use CGI::Carp 'fatalsToBrowser';
+use Constants qw($URLBASE);
+
+my $id = param('id');
+my $direction = param('d');
+
+my $articles = Articles->new;
+
+my $article = $articles->getByPkey($id)
+  or die "Could not find article $id";
+
+# get our siblings, in order
+my @siblings;
+if (param('all')) {
+  @siblings = sort { $b->{displayOrder} <=> $a->{displayOrder} }
+                      $articles->children($article->{parentid});
+}
+else {
+  @siblings = $articles->listedChildren($article->{parentid});
+}
+
+# find our article
+my $index;
+for ($index = 0; $index < @siblings; ++$index) {
+  last if $siblings[$index]{id} == $id;
+}
+
+die "This program is broken - couldn't find self in list of parents children"
+  if $index == @siblings;
+
+if ($direction eq 'down') {
+  die "There is no next article to swap with"
+    if $index == $#siblings;
+  ($article->{displayOrder}, $siblings[$index+1]{displayOrder})
+    = ($siblings[$index+1]{displayOrder}, $article->{displayOrder});
+  $siblings[$index+1]->save();
+}
+elsif ($direction eq 'up') {
+  die "There is no previous article to swap with"
+    if $index == 0;
+  ($article->{displayOrder}, $siblings[$index-1]{displayOrder})
+    = ($siblings[$index-1]{displayOrder}, $article->{displayOrder});
+  $siblings[$index-1]->save();
+  
+}
+else {
+  die "Sorry, can't move articles sideways";
+}
+
+$article->save();
+use Util 'generate_article';
+generate_article('Articles', $article);
+
+
+if (param('refreshto')) {
+  print "Refresh: 0; url=\"$URLBASE",param('refreshto'),"\"\n";
+}
+elsif (param('edit')) {
+  # refresh back to editor
+  print "Refresh: 0; url=\"$URLBASE/cgi-bin/admin/add.pl?id=$article->{parentid}#children\"\n";
+}
+else {
+  # refresh back to the parent
+  my $parent = $articles->getByPkey($article->{parentid});
+  print "Refresh: 0; url=\"$URLBASE$parent->{admin}\"\n";
+}
+print "Content-Type: text/html\n\n<html></html>\n";
diff --git a/site/cgi-bin/admin/shopadmin.pl b/site/cgi-bin/admin/shopadmin.pl
new file mode 100755 (executable)
index 0000000..5d84152
--- /dev/null
@@ -0,0 +1,694 @@
+#!/usr/bin/perl -w
+use strict;
+use lib '../modules';
+use CGI ':standard';
+use CGI::Carp 'fatalsToBrowser';
+#use Carp; # 'verbose';
+use Products;
+use Product;
+use Orders;
+use Order;
+use OrderItems;
+use OrderItem;
+use Constants qw($TMPLDIR);
+use Squirrel::Template;
+use Squirrel::ImageEditor;
+use Constants qw($SHOPID $PRODUCTPARENT $SECURLBASE 
+                 $SHOP_URI $CGI_URI $IMAGES_URI $AUTO_GENERATE);
+use CGI::Cookie;
+use Apache::Session::MySQL;
+use Images;
+use Articles;
+
+my %cookies = fetch CGI::Cookie;
+my $sessionid;
+$sessionid = $cookies{sessionid}->value if exists $cookies{sessionid};
+my %session;
+
+my $dh = single DatabaseHandle;
+eval {
+  tie %session, 'Apache::Session::MySQL', $sessionid,
+    {
+     Handle=>$dh->{dbh},
+     LockHandle=>$dh->{dbh}
+    };
+};
+if ($@ && $@ =~ /Object does not exist/) {
+  # try again
+  undef $sessionid;
+  tie %session, 'Apache::Session::MySQL', $sessionid,
+    {
+     Handle=>$dh->{dbh},
+     LockHandle=>$dh->{dbh}
+    };
+}
+unless ($sessionid) {
+  # save the new sessionid
+  print "Set-Cookie: ",CGI::Cookie->new(-name=>'sessionid', -value=>$session{_session_id}),"\n";
+}
+
+# this shouldn't be necessary, but it stopped working and this fixed it
+# <sigh>
+END {
+  untie %session;
+}
+
+my %acts;
+%acts = 
+  (
+   articleType=>sub { 'Product' },
+  );
+
+param();
+
+my $imageEditor = Squirrel::ImageEditor->new(session=>\%session,
+                                            extras=>\%acts,
+                                            keep => [ 'id' ]);
+
+
+my %what_to_do =
+  (
+   order_list=>\&order_list,
+   order_detail=>\&order_detail,
+   edit_product=>\&edit_product,
+   add_product=>\&add_product,
+   save_product=>\&save_product,
+   delete_product=>\&delete_product,
+   undelete_product=>\&undelete_product,
+   product_detail=>\&product_detail,
+   back=>\&img_return,
+  );
+
+my @modifiable = qw(body retailPrice wholesalePrice gst release expire parentid leadTime);
+my %modifiable = map { $_=>1 } @modifiable;
+
+if ($imageEditor->action($CGI::Q)) {
+  exit;
+}
+
+while (my ($key, $func) = each %what_to_do) {
+  if (param($key)) {
+    $func->();
+    exit;
+  }
+}
+
+product_list();
+
+#####################
+# product management
+
+sub product_list {
+  my @catalogs = Articles->children($SHOPID);
+  my $catalog_index = -1;
+  my $products = Products->new;
+  my @list = sort { $b->{displayOrder} cmp $a->{displayOrder} } $products->all;
+  my $list_index = -1;
+  my $message = param('message') || '';
+  use POSIX 'strftime';
+  my $today = strftime('%Y-%m-%d', localtime);
+  my %acts =
+    (
+     catalog=> sub { CGI::escapeHTML($catalogs[$catalog_index]{$_[0]}) },
+     iterate_catalogs =>
+     sub {
+       if (++$catalog_index < @catalogs) {
+         $list_index = -1;
+         @list = $products->getBy(parentid=>$catalogs[$catalog_index]{id});
+         return 1;
+       }
+       return 0;
+     },
+     product => sub { CGI::escapeHTML($list[$list_index]{$_[0]}) },
+     date => sub { display_date($list[$list_index]{$_[0]}) },
+     money => sub { sprintf("%.2f", $list[$list_index]{$_[0]}/100.0) },
+     iterate_products =>
+     sub {
+       return ++$list_index < @list;
+     },
+     script=>sub { $ENV{SCRIPT_NAME} },
+     message => sub { $message },
+     hiddenNote => 
+     sub { $list[$list_index]{listed} == 0 ? "Hidden" : "&nbsp;" },
+     shopid=>sub { $SHOPID },
+     move =>
+     sub {
+       # links to move up/down
+       my $html = '';
+       my $refreshto = CGI::escape($ENV{SCRIPT_NAME});
+       if ($list_index < $#list) {
+        $html .= <<HTML;
+<a href="$CGI_URI/admin/move.pl?id=$list[$list_index]{id}&d=down&refreshto=$refreshto&all=1"><img src="$IMAGES_URI/admin/move_down.gif" width="17" height="13" border="0" alt="Move Down" align="absbottom"></a>
+HTML
+       }
+       if ($list_index > 0) {
+        $html .= <<HTML;
+<a href="$CGI_URI/admin/move.pl?id=$list[$list_index]{id}&d=up&refreshto=$refreshto&all=1"><img src="$IMAGES_URI/admin/move_up.gif" width="17" height="13" border="0" alt="Move Up" align="absbottom"></a>
+HTML
+       }
+       return $html;
+     },
+    );
+
+  page('product_list', \%acts);
+}
+
+sub add_product {
+  my $product = { map { $_=>'' } Product->columns };
+
+  $product->{leadTime} = 0;
+  @$product{qw/retailPrice wholesalePrice gst/} = qw(0 0 0);
+  $product->{release} = '2000-01-01';
+  $product->{expire} = '9999-12-31';
+  $product->{parentid} = param('parentid')
+    if param('parentid');
+  if (!exists $session{imageid} || $session{imageid} ne '') {
+    $session{imageid} = '';
+    $imageEditor->set([], 'tr');
+  }
+
+  product_form($product, "Add New");
+}
+
+sub edit_product {
+  my $id = param('id');
+  $id or shop_redirect('?product_list=1');
+  my $product = Products->getByPkey($id)
+    or shop_redirect("?message=Product+$id+not+found");
+  if (!exists $session{imageid} || $session{imageid} != $id) {
+    my @images = Images->getBy('articleId', $id);
+    $session{imageid} = $id;
+    $imageEditor->set(\@images, $product->{imagePos});
+  }
+  
+  product_form($product, "Edit", '', 'edit_product');
+}
+
+sub save_product {
+  my %product;
+
+  for my $col (Product->columns) {
+    $product{$col} = param($col) if defined param($col);
+  }
+
+  my $original;
+  # we validate in here
+  eval {
+    if ($product{id}) {
+      $original = Products->getByPkey($product{id})
+       or shop_redirect("?message=Product+$product{id}+not+found");
+    }
+    if ($original) {
+      # remove unmodifiable fields
+      for my $key (keys %product) {
+       $modifiable{$key} or delete $product{$key};
+      }
+    }
+    else {
+      $product{title} !~ /^\s*$/
+       or die "No title entered";
+      $product{summary} !~ /^\s*$/
+       or die "No summary entered\n";
+      $product{body} !~ /^\s*$/
+       or die "No description entered\n";
+      $product{leadTime} =~ /^\d+$/
+       or die "No lead time entered\n";
+
+    }
+    use AdminUtil 'save_thumbnail';
+    save_thumbnail($original, \%product);
+    sql_date(\$product{release})
+      or die "Invalid release date\n";
+    sql_date(\$product{expire})
+      or die "Invalid expiry date\n";
+    money_to_cents(\$product{retailPrice})
+      or die "Invalid price\n";
+    money_to_cents(\$product{wholesalePrice})
+      or $product{wholesalePrice} = undef;
+    money_to_cents(\$product{gst})
+      or die "Invalid gst\n";
+  };
+  if ($@) {
+    # CGI::Carp messes with the die message <sigh>
+    $@ =~ s/\[[^\]]*\][^:]+://; 
+    if ($original) {
+      for my $key (keys %$original) {
+       $product{$key} = $original->{key};
+      }
+    }
+    product_form(\%product, $original ? "Edit" : "Add New", $@);
+    return;
+  }
+
+  # save the product
+  $product{parentid} ||= $PRODUCTPARENT;
+  $product{titleImage} = '';
+  $product{keyword} ||= '';
+  $product{template} = 'shopitem.tmpl';
+  $product{threshold} = 0; # ignored
+  $product{summaryLength} = 200; # ignored
+  $product{level} = 2;
+  $product{lastModified} = epoch_to_sql(time);
+  $product{imagePos} = $imageEditor->imagePos || 'tr';
+  $product{generator} = 'Generate::Product';
+  
+  if ($original) {
+    @$original{keys %product} = values %product;
+    $original->save();
+
+    # out with the old
+    my @oldimages = Images->getBy('articleId', $original->{id});
+    for my $image (@oldimages) {
+      $image->remove();
+    }
+    # in with the new
+    my @images = $imageEditor->images();
+    for my $image (@images) {
+      Images->add($original->{id}, @$image{qw/image alt width height/});
+    }
+    $imageEditor->clear();
+    delete $session{imageid};
+
+    use Util 'generate_article';
+    generate_article('Articles', $original) if $AUTO_GENERATE;
+
+    shop_redirect('?message=Saved'); # redirect to product list
+  }
+  else {
+    # set these properly afterwards
+    $product{link} = '';
+    $product{admin} = '';
+    $product{listed} = 2;
+    $product{displayOrder} = time;
+
+    my @data = @product{Product->columns};
+    shift @data;
+
+    my $product = Products->add(@data);
+    if (!$product) {
+      for my $key (keys %$original) {
+       $product{$key} = $original->{$key} unless defined $product{$key};
+      }
+      product_form(\%product, "Add New", DBI->errstr);
+    }
+    else {
+      # update the link info
+      $product->{link} = $SECURLBASE . $SHOP_URI . '/shop'.$product->{id}.'.html';
+      $product->{admin} = "$CGI_URI/admin/admin.pl?id=$product->{id}";
+      $product->save();
+
+      # and save the images
+      my @images = $imageEditor->images();
+      for my $image (@images) {
+       Images->add($product->{id}, @$image{qw/image alt width height/});
+      }
+      $imageEditor->clear();
+      delete $session{imageid};
+
+      use Util 'generate_article';
+      generate_article('Articles', $product) if $AUTO_GENERATE;
+
+      shop_redirect(''); # redirect to product list
+    }
+  }
+}
+
+sub delete_product {
+  my $id = param('id');
+  if ($id and
+     my $product = Products->getByPkey($id)) {
+    $product->{listed} = 0;
+    $product->save();
+    use Util 'generate_article';
+    generate_article('Articles', $product) if $AUTO_GENERATE;
+    shop_redirect("?message=Product+hidden");
+  }
+  else {
+    product_list();
+  }
+}
+
+sub undelete_product {
+  my $id = param('id');
+  if ($id and
+     my $product = Products->getByPkey($id)) {
+    $product->{listed} = 1;
+    $product->save();
+    use Util 'generate_article';
+    generate_article('Articles', $product) if $AUTO_GENERATE;
+    shop_redirect("?message=Product+shown");
+  }
+  else {
+    product_list();
+  }
+}
+
+sub product_detail {
+  my $id = param('id');
+  if ($id and
+      my $product = Products->getByPkey($id)) {
+    product_form($product, '', '', 'product_detail');
+  }
+  else {
+    product_list();
+  }
+}
+sub product_form {
+  my ($product, $action, $message, $template) = @_;
+
+  defined($message) or $message = '';
+  $template ||= 'add_product';
+  my @catalogs = sort { $b->{displayOrder} <=> $a->{displayOrder} } 
+                          Articles->children($SHOPID);
+
+  my %acts;
+  %acts =
+    (
+     catalogs => 
+     sub {
+       return popup_menu(-name=>'parentid',
+                         -values=>[ map $_->{id}, @catalogs ],
+                         -labels=>{ map { @$_{qw/id title/} } @catalogs },
+                         -default=>($product->{parentid} || $PRODUCTPARENT),
+                         -override=>1);
+     },
+     product => sub { CGI::escapeHTML($product->{$_[0]}) },
+     date => sub { display_date($product->{$_[0]}) },
+     money => sub { sprintf("%.2f", $product->{$_[0]}/100.0) },
+     action => sub { $action },
+     message => sub { $message },
+     script=>sub { $ENV{SCRIPT_NAME} },
+     ifImage => sub { $product->{imageName} },
+     hiddenNote => sub { $product->{listed} ? "&nbsp;" : "Hidden" },
+    );
+
+  page($template, \%acts);
+}
+
+sub img_return {
+  if (exists $session{imageid}) {
+    if ($session{imageid}) {
+      param('id', $session{imageid});
+      edit_product();
+    }
+    else {
+      add_product();
+    }
+  }
+  else {
+    product_list(); # something wierd
+  }
+}
+
+#####################
+# order management
+
+sub order_list {
+  my $orders = Orders->new;
+  my @orders = sort { $b->{orderDate} cmp $a->{orderDate} } $orders->all;
+
+  my $order_index = -1;
+  my %acts;
+  %acts =
+    (
+     order=> sub { CGI::escapeHTML($orders[$order_index]{$_[0]}) },
+     iterate_orders => sub { ++$order_index < @orders },
+     money => sub { sprintf("%.2f", $orders[$order_index]{$_[0]}/100.0) },
+     date => sub { display_date($orders[$order_index]{$_[0]}) },
+     script => sub { $ENV{SCRIPT_NAME} },
+    );
+  page('order_list', \%acts);
+}
+
+sub order_detail {
+  my $id = param('id');
+  if ($id and
+      my $order = Orders->getByPkey($id)) {
+    my @lines = OrderItems->getBy('orderId', $id);
+    my $line_index = -1;
+    my $product;
+    my %acts;
+    %acts =
+      (
+       item => sub { CGI::escapeHTML($lines[$line_index]{$_[0]}) },
+       iterate_items => 
+       sub { 
+        if (++$line_index < @lines ) {
+          $product = Products->getByPkey($lines[$line_index]{productId});
+        }
+        else {
+          return 0;
+        }
+       },
+       order => sub { CGI::escapeHTML($order->{$_[0]}) },
+       money => 
+       sub { 
+        my ($func, $args) = split ' ', $_[0], 2;
+        return sprintf("%.2f", $acts{$func}->($args)/100.0)
+       },
+       date =>
+       sub {
+        my ($func, $args) = split ' ', $_[0], 2;
+        return display_date($acts{$func}->($args));
+       },
+       extension =>
+       sub {
+        sprintf("%.2f", $lines[$line_index]{units} * $lines[$line_index]{$_[0]}/100.0)
+       },
+       product => sub { CGI::escapeHTML($product->{$_[0]}) },
+       script => sub { $ENV{SCRIPT_NAME} },
+      );
+    page('order_detail', \%acts);
+  }
+  else {
+    order_list();
+  }
+}
+
+#####################
+# utilities
+# perhaps some of these belong in a class...
+
+sub page {
+  my ($which, $acts, $iter) = @_;
+
+  my $templ = Squirrel::Template->new;
+
+  print "Content-Type: text/html\n\n";
+  print $templ->show_page($TMPLDIR, $which . ".tmpl", $acts, $iter);
+}
+
+sub shop_redirect {
+  my $url = shift;
+  print "Content-Type: text/html\n";
+  print "Refresh: 0; url=\"$ENV{SCRIPT_NAME}$url\"\n\n<html></html>\n";
+  exit;
+}
+
+# format an ANSI SQL date for display
+sub display_date {
+  my ($date) = @_;
+  
+  if ( my ($year, $month, $day) = 
+       ($date =~ /^(\d+)-(\d+)-(\d+)/)) {
+    return sprintf("%02d/%02d/%04d", $day, $month, $year);
+  }
+  return $date;
+}
+
+# convert a user entered date from dd/mm/yyyy to ANSI sql format
+# we try to parse flexibly here
+sub sql_date {
+  my $str = shift;
+  my ($year, $month, $day);
+
+  # look for a date
+  if (($day, $month, $year) = ($$str =~ m!(\d+)/(\d+)/(\d+)!)) {
+    $year += 2000 if $year < 100;
+
+    return $$str = sprintf("%04d-%02d-%02d", $year, $month, $day);
+  }
+  return undef;
+}
+
+sub money_to_cents {
+  my $money = shift;
+
+  $$money =~ /^\s*(\d+(\.\d*)|\.\d+)/
+    or return undef;
+  return $$money = sprintf("%.0f ", $$money * 100);
+}
+
+# convert an epoch time to sql format
+sub epoch_to_sql {
+  use POSIX 'strftime';
+  my ($time) = @_;
+
+  return strftime('%Y-%m-%d', localtime $time);
+}
+
+
+__END__
+
+=head1 NAME
+
+shopadmin.pl - administration for the online-store tables
+
+=head1 SYNOPSYS
+
+(This is a CGI script.)
+
+=head1 DESCRIPTION
+
+shopadmin.pl gives a UI to edit the product table, and view the orders and 
+order_item tables.
+
+=head1 TEMPLATES
+
+shopadmin.pl uses a few templates from the templates directory.
+
+=head2 product_list.tmpl
+
+=over 4
+
+=item product I<name>
+
+Access to product fields.
+
+=item date I<name>
+
+Formats the I<name> field of the product as a date.
+
+=item money I<name>
+
+Formats the I<name> integer field as a 2 decimal place money value.
+
+=item iterator ... products
+
+Iterates over the products database in reverse expire order.
+
+=item script
+
+The name of the current script for use in URLs.
+
+=item message
+
+An error message that may have been passed in the 'message' parameter.
+
+=item hiddenNote
+
+'Deleted' if the expire date of the current product has passed.
+
+=back
+
+=head2 add_product.tmpl
+=head2 edit_product.tmpl
+=head2 product_detail.tmpl
+
+These use the same tags.
+
+=over 4
+
+=item product I<name>
+
+The specified field of the product.
+
+=item date I<name>
+
+Formats the given field of the product as a date.
+
+=item money I<name>
+
+Formats the given integer field of the product as money.
+
+=item action
+
+Either 'Add New' or 'Edit'.
+
+=item message
+
+The message parameter passed into the script.
+
+=item script
+
+The name of the script, for use in urls.
+
+=item ifImage
+
+Conditional, true if the product has an image.
+
+=item hiddenNote
+
+"Hidden" if the product is hidden.
+
+=back
+
+=head2 order_list.tmpl
+
+Used to display the list of orders.
+
+=over 4
+
+=item order I<name>
+
+The given field of the order.
+
+=item iterator ... orders
+
+Iterates over the orders in reverse orderDate order.
+
+=item money I<name>
+
+The given field of the current order formatted as money.
+
+=item date I<name>
+
+The given field of the current order formatted as a date.
+
+=item script
+
+The name of the script, for use in urls.
+
+=back
+
+=head2 order_detail.tmpl
+
+Used to display the details for an order.
+
+=over 4
+
+=item item I<name>
+
+Displays the given field of a line item
+
+=item iterator ... items
+
+Iterates over the line items in the order.
+
+=item order I<name>
+
+The given field of the order.
+
+=item money I<func> I<args>
+
+Formats the given functions return value as money.
+
+=item date I<func> I<args>
+
+Formats the  given function return value as a date.
+
+=item extension I<name>
+
+Takes the given field for the current item multiplied by the units column.
+
+=item product I<name>
+
+The given product field of the product for the current item.
+
+=item script
+
+The name of the current script (for use in urls).
+
+=back
+
+=cut
diff --git a/site/cgi-bin/modules/AdminUtil.pm b/site/cgi-bin/modules/AdminUtil.pm
new file mode 100644 (file)
index 0000000..bf91499
--- /dev/null
@@ -0,0 +1,61 @@
+package AdminUtil;
+use strict;
+
+require Exporter;
+use base qw(Exporter);
+use vars qw/@EXPORT_OK/;
+@EXPORT_OK = qw(save_thumbnail);
+
+sub save_thumbnail {
+  my ($original, $newdata) = @_;
+
+  use CGI qw(param);
+
+  unless ($original) {
+    @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
+  }
+  use Constants '$IMAGEDIR';
+  if (param('remove_thumb') && $original && $original->{thumbImage}) {
+    unlink("$IMAGEDIR/$original->{thumbImage}");
+    @$newdata{qw/thumbImage thumbWidth thumbHeight/} = ('', 0, 0);
+  }
+  my $image = param('thumbnail');
+  if ($image && -s $image) {
+    # where to put it...
+    my $name = '';
+    $image =~ /([\w.-]+)$/ and $name = $1;
+    my $filename = time . "_" . $name;
+
+    use Fcntl;
+    my $counter = "";
+    $filename = time . '_' . $counter . '_' . $name
+      until sysopen( OUTPUT, "$IMAGEDIR/$filename", 
+                     O_WRONLY| O_CREAT| O_EXCL)
+        || ++$counter > 100;
+
+    fileno(OUTPUT) or die "Could not open image file: $!";
+    binmode OUTPUT;
+    my $buffer;
+
+    #no strict 'refs';
+
+    # read the image in from the browser and output it to our 
+    # output filehandle
+    print STDERR "\$image ",ref $image,"\n";
+    seek $image, 0, 0;
+    print OUTPUT $buffer while sysread $image, $buffer, 1024;
+
+    close OUTPUT
+      or die "Could not close image output file: $!";
+
+    use Image::Size;
+
+    if ($original && $original->{thumbImage}) {
+      #unlink("$IMAGEDIR/$original->{thumbImage}");
+    }
+    @$newdata{qw/thumbWidth thumbHeight/} = imgsize("$IMAGEDIR/$filename");
+    $newdata->{thumbImage} = $filename;
+  }
+}
+
+1;
diff --git a/site/cgi-bin/modules/Article.pm b/site/cgi-bin/modules/Article.pm
new file mode 100644 (file)
index 0000000..87e6850
--- /dev/null
@@ -0,0 +1,15 @@
+package Article;
+
+# represents an article from the database
+use Squirrel::Row;
+use vars qw/@ISA/;
+@ISA = qw/Squirrel::Row/;
+
+sub columns {
+  return qw/id parentid displayOrder title titleImage body
+    thumbImage thumbWidth thumbHeight imagePos
+    release expire keyword template link admin threshold
+    summaryLength generator level listed lastModified/;
+}
+
+1;
diff --git a/site/cgi-bin/modules/Articles.pm b/site/cgi-bin/modules/Articles.pm
new file mode 100644 (file)
index 0000000..7aca36a
--- /dev/null
@@ -0,0 +1,42 @@
+package Articles;
+
+use Squirrel::Table;
+use vars qw(@ISA $VERSION);
+@ISA = qw(Squirrel::Table);
+
+sub rowClass {
+  return 'Article';
+}
+
+# returns a list of articles which are sections
+sub sections {
+  my ($self) = @_;
+
+  return $self->getBy('level', 1);
+}
+
+# returns a list of articles which are sub sections
+sub subsections {
+  my ($self) = @_;
+
+  return $self->getBy('level', 2);
+}
+
+# child articles of the given child id
+sub children {
+  my ($self, $id) = @_;
+
+  return $self->getBy('parentid', $id);
+}
+
+# children of the given article that are listed and in the display order
+sub listedChildren {
+  my ($self, $id) = @_;
+  my ($year, $month, $day) = (localtime)[5,4,3];
+  my $today = sprintf("%04d-%02d-%02d 00:00:00", $year+1900, $month+1, $day);
+  return sort { $b->{displayOrder} <=> $a->{displayOrder} }
+    grep { $_->{listed} && $today ge $_->{release} 
+            && $today le $_->{expire}} $self->children($id);
+}
+
+1;
diff --git a/site/cgi-bin/modules/DatabaseHandle.pm b/site/cgi-bin/modules/DatabaseHandle.pm
new file mode 100644 (file)
index 0000000..2c6116f
--- /dev/null
@@ -0,0 +1,73 @@
+package DatabaseHandle;
+require 5.005;
+
+$DatabaseHandle::VERSION = '0.1';
+
+use Constants 0.1 qw/$DBD $DB $UN $PW/;
+
+use DBI;
+
+my $self = undef;
+
+sub single
+{
+       my $class = shift;
+       warn "Incorrect number of parameters passed to DatabaseHandle::single\n" unless @_ == 0;
+
+       unless ( defined $self )
+       {
+               my $dbh = DBI->connect( "DBI:$DBD:database=$DB", $UN, $PW)
+                   or die "Cannot connect to database: $DBI::errstr";
+
+               $self = bless { dbh => $dbh,
+                               Articles => $dbh->prepare('select * from article'),
+                               Images => $dbh->prepare('select * from image'),
+                               
+                               replaceArticle    => $dbh->prepare( 'replace article    values (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)'),
+                               replaceImage => $dbh->prepare('replace image values (?,?,?,?,?,?)'),
+
+                               addArticle    => $dbh->prepare( 'insert article values (null, ?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)'),
+                               addImage => $dbh->prepare('insert image values(null, ?, ?, ?, ?, ?)'),
+
+                               deleteArticle => $dbh->prepare( 'delete from article where id = ?'),
+                               deleteImage => $dbh->prepare('delete from image where id = ?'),
+
+                               getImageByArticleId => $dbh->prepare('select * from image where articleId = ?'),
+
+                               getArticleByPkey => $dbh->prepare('select * from article where id = ?'),
+
+                               getArticleByLevel => $dbh->prepare('select * from article where level = ?'),
+                               getArticleByParentid => $dbh->prepare('select * from article where parentid = ?'),
+                               dropIndex => $dbh->prepare('delete from searchindex'),
+                               insertIndex => $dbh->prepare('insert searchindex values(?, ?, ?, ?)'),
+                               searchIndex => $dbh->prepare('select * from searchindex where id = ?'),
+
+                               Products=> $dbh->prepare('select article.*, product.* from article, product where id = articleId'),
+                               addProduct => $dbh->prepare('insert product values(?,?,?,?,?,?)'),
+                               getProductByPkey => $dbh->prepare('select article.*, product.* from article, product where id=? and articleId = id'),
+                               replaceProduct => $dbh->prepare('replace product values(?,?,?,?,?,?)'),
+
+                               Orders => $dbh->prepare('select * from orders'),
+                               getOrderByPkey => $dbh->prepare('select * from orders where id = ?'),
+                               getOrderItemByOrderId => $dbh->prepare('select * from order_item where orderId = ?'),
+                               addOrder => $dbh->prepare('insert orders values(null,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)'),
+                               addOrderItem => $dbh->prepare('insert order_item values(null,?,?,?,?,?,?)'),
+
+                             }, $class;
+       }
+       $self;
+}
+
+# gotta love this
+sub DESTROY
+{
+  # this is wierd - we only need to reset this on 5.6.x (for x == 0 so
+  # far)
+  # Works fine without the reset for 5.005_03
+  if ($dbh) {
+    $dbh->disconnect;
+    undef $dbh;
+  }
+}
+
+1;
diff --git a/site/cgi-bin/modules/Generate/Product.pm b/site/cgi-bin/modules/Generate/Product.pm
new file mode 100644 (file)
index 0000000..d689232
--- /dev/null
@@ -0,0 +1,113 @@
+package Generate::Product;
+use strict;
+use Generate::Article;
+use Products;
+use Images;
+use base qw(Generate::Article);
+use Squirrel::Template;
+use Constants qw($TMPLDIR %TEMPLATE_OPTS $URLBASE $CGI_URI $ADMIN_URI);
+
+sub edit_link {
+  my ($self, $id) = @_;
+  return "/cgi-bin/admin/shopadmin.pl?id=$id&edit_product=1";
+}
+
+sub generate {
+  my ($self, $article, $articles) = @_;
+
+  my $product = Products->getByPkey($article->{id});
+  my %acts;
+  %acts =
+    (
+     $self->baseActs($articles, \%acts, $article, 0),
+     product=> sub { CGI::escapeHTML($product->{$_[0]}) },
+     admin =>
+     sub {
+       return '' unless $self->{admin};
+       my $html = <<HTML;
+<table>
+<tr>
+<td><form action="$CGI_URI/admin/shopadmin.pl">
+<input type=hidden name="edit_product" value=1>
+<input type=hidden name=id value=$product->{id}>
+<input type=submit value="Edit Product"></form></td>
+<td><form action="$ADMIN_URI">
+<input type=submit value="Admin menu">
+</form></td>
+<td><form action="$CGI_URI/admin/admin.pl" target="_blank">
+<input type=submit value="Display">
+<input type=hidden name=admin value=0>
+<input type=hidden name=id value="$product->{id}"></form></td>
+</tr>
+</table>
+HTML
+     },
+    );
+  return Squirrel::Template->new(%TEMPLATE_OPTS)
+    ->show_page($TMPLDIR, $article->{template}, \%acts);
+}
+
+sub visible {
+  my ($self, $article) = @_;
+  return $article->{listed};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+  Generate::Product - generates product detail pages for BSE
+
+=head1 DESCRIPTION
+
+Like the NAME says.
+
+=head1 TAGS
+
+=over 4
+
+=item product I<field>
+
+Access to product fields of the product being rendered.  This is the
+same as the C<article> I<field> tag for normal articles, but also give
+you access to the product fields.
+
+=item admin
+
+Produces product specific administration links in admin mode.
+
+=back
+
+=head2 Product specific fields
+
+=over 4
+
+=item summary
+
+An in-between length description of the article for use on the catalog
+page.
+
+=item leadTime
+
+The number of days it takes to receive the product after it has been
+ordered.
+
+=item retailPrice
+
+The cost to the customer of the product.  You need to use the C<money>
+tag to format this field for display.
+
+=item wholesalePrice
+
+Your cost.  You need to use the C<money> tag to format this field for
+display.
+
+=item gst
+
+The GST (in Australia) payable on the product.
+
+=back
+
+=cut
diff --git a/site/cgi-bin/modules/Image.pm b/site/cgi-bin/modules/Image.pm
new file mode 100644 (file)
index 0000000..67652a0
--- /dev/null
@@ -0,0 +1,12 @@
+package Image;
+
+# represents an image from the database
+use Squirrel::Row;
+use vars qw/@ISA/;
+@ISA = qw/Squirrel::Row/;
+
+sub columns {
+  return qw/id articleId image alt width height/;
+}
+
+1;
diff --git a/site/cgi-bin/modules/Images.pm b/site/cgi-bin/modules/Images.pm
new file mode 100644 (file)
index 0000000..3b97349
--- /dev/null
@@ -0,0 +1,11 @@
+package Images;
+
+use Squirrel::Table;
+use vars qw(@ISA $VERSION);
+@ISA = qw(Squirrel::Table);
+
+sub rowClass {
+  return 'Image';
+}
+
+1;
diff --git a/site/cgi-bin/modules/Order.pm b/site/cgi-bin/modules/Order.pm
new file mode 100644 (file)
index 0000000..e59a2e9
--- /dev/null
@@ -0,0 +1,19 @@
+package Order;
+
+# represents an order from the database
+use Squirrel::Row;
+use vars qw/@ISA/;
+@ISA = qw/Squirrel::Row/;
+
+sub columns {
+  return qw/id
+           delivFirstName delivLastName delivStreet delivSuburb delivState
+          delivPostCode delivCountry
+           billFirstName billLastName billStreet billSuburb billState
+           billPostCode billCountry
+           telephone facsimile emailAddress
+           total wholesaleTotal gst orderDate
+           ccNumberHash ccName ccExpiryHash ccType/;
+}
+
+1;
diff --git a/site/cgi-bin/modules/OrderItem.pm b/site/cgi-bin/modules/OrderItem.pm
new file mode 100644 (file)
index 0000000..320e0c8
--- /dev/null
@@ -0,0 +1,12 @@
+package OrderItem;
+
+# represents an order line item from the database
+use Squirrel::Row;
+use vars qw/@ISA/;
+@ISA = qw/Squirrel::Row/;
+
+sub columns {
+  return qw/id productId orderId units price wholesalePrice gst/;
+}
+
+1;
diff --git a/site/cgi-bin/modules/OrderItems.pm b/site/cgi-bin/modules/OrderItems.pm
new file mode 100644 (file)
index 0000000..9867a69
--- /dev/null
@@ -0,0 +1,11 @@
+package OrderItems;
+
+use Squirrel::Table;
+use vars qw(@ISA $VERSION);
+@ISA = qw(Squirrel::Table);
+
+sub rowClass {
+  return 'OrderItem';
+}
+
+1;
diff --git a/site/cgi-bin/modules/Orders.pm b/site/cgi-bin/modules/Orders.pm
new file mode 100644 (file)
index 0000000..2d044d3
--- /dev/null
@@ -0,0 +1,11 @@
+package Orders;
+
+use Squirrel::Table;
+use vars qw(@ISA $VERSION);
+@ISA = qw(Squirrel::Table);
+
+sub rowClass {
+  return 'Order';
+}
+
+1;
diff --git a/site/cgi-bin/modules/Product.pm b/site/cgi-bin/modules/Product.pm
new file mode 100644 (file)
index 0000000..1773cb5
--- /dev/null
@@ -0,0 +1,17 @@
+package Product;
+
+# represents a product from the database
+use Article;
+use vars qw/@ISA/;
+@ISA = qw/Article/;
+
+sub columns {
+  return ($_[0]->SUPER::columns(), 
+         qw/articleId summary leadTime retailPrice wholesalePrice gst/ );
+}
+
+sub bases {
+  return { articleId=>{ class=>'Article'} };
+}
+
+1;
diff --git a/site/cgi-bin/modules/Products.pm b/site/cgi-bin/modules/Products.pm
new file mode 100644 (file)
index 0000000..430cc31
--- /dev/null
@@ -0,0 +1,11 @@
+package Products;
+
+use Squirrel::Table;
+use vars qw(@ISA $VERSION);
+@ISA = qw(Squirrel::Table);
+
+sub rowClass {
+  return 'Product';
+}
+
+1;
diff --git a/site/cgi-bin/modules/Squirrel/GPG.pm b/site/cgi-bin/modules/Squirrel/GPG.pm
new file mode 100644 (file)
index 0000000..ed1b2a9
--- /dev/null
@@ -0,0 +1,162 @@
+package Squirrel::GPG;
+
+sub new {
+  return bless {}, $_[0];
+}
+
+sub error {
+  return $_[0]->{error};
+}
+
+sub encrypt {
+  my ($self, $recips, $data, %opts) = @_;
+
+  my @recips = ref $recips ? @$recips : ( $recips );
+  my $cmd = $opts{gpg} || 'gpg';
+  $cmd .= ' ';
+  ++$opts{sign} if $opts{secretkeyid};
+  my $flags = "aqe";
+  if ($opts{sign} && !$opts{passphrase}) {
+    $self->{error} = "Cannot sign without passphrase"; 
+    return;
+  }
+  
+  $flags .= "s" if $opts{sign};
+  $cmd .= "-$flags ";
+  $cmd .= "-u $opts{secretkeyid} " if $opts{secretkeyid};
+  $cmd .= $opts{opts} if $opts{opts};
+  for (@recips) {
+    $cmd .= "-r '$_' ";
+  }
+  $cmd .= "--no-tty ";
+  # do the deed
+  my $child = open CHILD, "-|";
+  defined $child or do { $self->{error} = "Cannot fork: $!"; return };
+  unless ($child) {
+    $cmd .= "--passphrase-fd 0 " if $opts{sign};
+    if ($opts{home}) {
+      $ENV{HOME} = $opts{home};
+    }
+    else {
+      my @uinfo = getpwuid $<;
+      if (@uinfo) {
+        $ENV{HOME} = $uinfo[7];
+        print STDERR "HOME set to $ENV{HOME}\n" if $opts{debug};
+      }
+      else {
+        print STDERR "Could not get user info for $<\n" if $opts{debug};
+      }
+    }
+    print STDERR "GPG command: $cmd\n" if $opts{debug};
+    if (open PGP, "| $cmd 2>&1") {
+      select(PGP); $| = 1; select(STDOUT);
+      print PGP $opts{passphrase}, "\n" if $opts{sign};
+      print PGP $data;
+      close PGP
+       or do { print "*ERROR* $?/$!\n"; exit 1; };
+    }
+    else {
+      print "*ERROR* $!\n";
+      exit 1;
+    }
+
+    exit 0; # finish the child
+  }
+
+  # ... and back in the parent process
+  my @data = <CHILD>;
+  my $result = close CHILD;
+  print STDERR "GPG Output", @data if $opts{debug};
+  if ($opts{stripwarn} && $data[0] =~ /^\w+: Warning:/) {
+    shift @data;
+  }
+  if (!$result) {
+    # something went wrong, try to figure out what
+    if ($? >> 8) {
+      # first child returned non-zero
+      my @errors = grep /^\*ERROR*/, @data;
+      if (@errors) {
+       $self->{error} = substr($errors[0], 7);
+      }
+      else {
+       $self->{error} = "Unknown error";
+      }
+    }
+    else {
+      $self->{error} = "Unknown error: $!";
+    }
+    return undef;
+  }
+
+  return join('', @data);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+  Squirrel::GPG
+
+=head1 SYNOPSIS
+
+  use Squirrel::GPG;
+  my $gpg = Squirrel::GPG->new;
+  my $data = ...;
+  my @recips = ( 'foo@bar.com' );
+  my $pass = ...; # passphase, required for sign
+  my $keyid = '9876BCED';
+  my $crypted = $gpg->encrypt(\@recips, $data, passphrase=>$pass,
+                             sign=>1, keyid=>$keyid)
+    or die "Cannot encrypt: ",$gpg->error;
+
+=head1 METHODS
+
+=over 4
+
+=item $gpg->encrypt(\@recips, $data, %opts)
+
+Encrypts $data using the public keys of @recips.  %opts can contain
+the following keys:
+
+gpg - path to the gpg executable (defaults to just 'gpg')
+
+sign - the message is signed with the user's private key if this is
+true.  The passphrase must also be set.
+
+passphrase - the passphrase used to access the private key
+
+secretkeyid - the secret key used to sign the message
+
+debug - if set then some debugging information will be written to STDERR
+
+opts - extra command-line options
+
+stripwarn - strips the insecure memory warning from the output if
+present (see BUGS in gpg(1))
+
+home - used to set the HOME environment variable.  If this isn't set
+then the $dir result from getpwuid $< will be used.
+
+=item $gpg->error()
+
+Returns the last error seen.
+
+=back
+
+=head1 BUGS
+
+Doesn't attempt to overwrite copies of keys and so on.  This probably
+isn't worth the trouble in Perl, since copies of all that would have
+been in mortals passed into functions.
+
+Doesn't handle error returns from gpg (ie. output to STDERR).
+
+Needs more documentation.
+
+=head1 SEE ALSO
+
+Squirrel::PGP6(3), gpg(1)
+
+=cut
diff --git a/site/cgi-bin/modules/Squirrel/ImageEditor.pm b/site/cgi-bin/modules/Squirrel/ImageEditor.pm
new file mode 100644 (file)
index 0000000..7711fe0
--- /dev/null
@@ -0,0 +1,287 @@
+package Squirrel::ImageEditor;
+#use CGI 'param';
+use strict;
+use Constants qw($URLBASE $TMPLDIR %TEMPLATE_OPTS);
+
+sub new {
+  my ($class, %opts) = @_;
+  $opts{message} = '';
+  $opts{template} ||= 'article_img.tmpl';
+  return bless \%opts, $_[0];
+}
+
+my @actions = qw(artimg addimg showimages process);
+
+sub action {
+  my ($self, $query) = @_;
+
+  use Data::Dumper;
+  #print STDERR "Images ",Dumper($self->{session}{images});
+
+  for my $action (@actions) {
+    if (defined $query->param($action)) {
+      $self->$action($query);
+      return 1;
+    }
+  }
+  for my $param ($query->param()) {
+    if ($param =~ /^removeimg_(\d+)/) {
+      $self->remove_img($query, $1);
+      return 1;
+    }
+    if ($param =~ /^moveimgup_(\d+)/) {
+      $self->moveup($query, $1);
+      return 1;
+    }
+    if ($param =~ /^moveimgdown_(\d+)/) {
+      $self->movedown($query, $1);
+      return 1;
+    }
+  }
+
+  return 0;
+}
+
+sub set {
+  my ($self, $images, $image_pos) = @_;
+
+  #use Data::Dumper;
+  #print STDERR "set ",Dumper($images);
+
+  $self->{session}{images} = [ @$images ];
+  $self->{session}{imagePos} = $image_pos;
+}
+
+sub clear {
+  my $self = shift;
+  #print STDERR "clear\n";
+  delete @{$self->{session}}{qw/images imagePos/};
+}
+
+sub images {
+  my $self = shift;
+
+  return @{$self->{session}{images} || []};
+}
+
+sub imagePos {
+  my $self = shift;
+  
+  return $self->{session}{imagePos} || 'tr';
+}
+
+sub artimg {
+  my ($self, $query) = @_;
+  $self->images_update($query);
+  $self->page();
+}
+
+sub showimages {
+  my ($self, $query) = @_;
+  $self->artimg($query);
+}
+
+sub process {
+  my ($self, $query) = @_;
+  $self->artimg($query);
+}
+
+# handle any changes the user made
+sub images_update {
+  my ($self, $query) = @_;
+  my $imagePos = $query->param('imagePos');
+  my $old = $self->imagePos();
+  if (defined($imagePos) && $imagePos ne $old) {
+    $self->{session}{imagePos} = $imagePos;
+  }
+
+  my @images = $self->images();
+  my @alt = $query->param('alt');
+  if (@alt) {
+    for my $index (0 .. $#images) {
+      $images[$index]{alt} = $alt[$index];
+    }
+  }
+
+  #my @order = $query->param('order');
+  #if (@order) {
+  #  my @indexes = sort { $order[$a] <=> $order[$b]
+  #                       || $a <=> $b
+  #                     } 0..$#images;
+  #  @images = @images[@indexes];
+  #}
+
+  # regenerate the order field
+  for my $index (0 .. $#images) {
+    $images[$index]{order} = $index;
+  }
+  $self->{session}{images} = \@images;
+
+  return @images;
+}
+
+# add an image
+sub addimg {
+  my ($self, $query) = @_;
+  my @images = $self->images_update($query);
+
+  unless ($query->param('image')) {
+    $self->{message} = "Enter or select the name of an image file on your machine.";
+    $self->showimages($query);
+    return;
+  }
+  if (-z $query->param('image')) {
+    $self->{message} = "Image file is empty";
+    $self->showimages($query);
+    return;
+  }
+
+  my $image = $query->param('image');
+
+  my $basename = '';
+  $image =~ /([\w.-]+)$/ and $basename = $1;
+
+  # create a filename that we hope is unique
+  my $filename = time. '_'. $basename;
+
+  # for the sysopen() constants
+  use Fcntl;
+
+  use Constants '$IMAGEDIR';
+
+  # loop until we have a unique filename
+  my $counter="";
+  $filename = time. '_' . $counter . '_' . $basename 
+    until sysopen( OUTPUT, "$IMAGEDIR/$filename", O_WRONLY| O_CREAT| O_EXCL)
+      || ++$counter > 100;
+
+  fileno(OUTPUT) or die "Could not open image file: $!";
+
+  # for OSs with special text line endings
+  binmode OUTPUT;
+
+  my $buffer;
+
+  no strict 'refs';
+
+  # read the image in from the browser and output it to our output filehandle
+  print OUTPUT $buffer while read $image, $buffer, 1024;
+
+  # close and flush
+  close OUTPUT
+    or die "Could not close image file $filename: $!";
+
+  use Image::Size;
+
+  my($width,$height) = imgsize("$IMAGEDIR/$filename");
+
+  push(@images, { image=>$filename, alt=>$query->param('altIn'), height=>$height, 
+                 width=>$width });
+
+  $self->{session}{images} = \@images;
+  my $url = $self->_fix_url($query, "$URLBASE$ENV{SCRIPT_NAME}?showimages=");
+  print  "Refresh: 0; url=\"$url\"\n";
+  print "Content-type: text/html\n\n<HTML></HTML>\n";
+}
+
+# remove an image
+sub remove_img {
+  my ($self, $query, $index) = @_;
+  my @images = $self->images();
+  use Data::Dumper;
+  my ($image) = splice(@images, $index, 1);
+  unlink "$IMAGEDIR$image->{image}" if !$image->{id};
+  $self->{session}{images} = \@images;
+
+  my $url = $self->_fix_url($query, "$URLBASE$ENV{SCRIPT_NAME}?showimages=");
+  print  "Refresh: 0; url=\"$url\"\n";
+  print "Content-type: text/html\n\n<HTML></HTML>\n";
+}
+
+# move an image up (swap it with the previous image)
+sub moveup {
+  my ($self, $query, $index) = @_;
+  my @images = $self->images;
+  if ($index > 0 && $index < @images) {
+    @images[$index-1, $index] = @images[$index, $index-1];
+    $self->{session}{images} = \@images;
+  }
+
+  my $url = $self->_fix_url($query, "$URLBASE$ENV{SCRIPT_NAME}?showimages=");
+  print  "Refresh: 0; url=\"$url\"\n";
+  print "Content-type: text/html\n\n<HTML></HTML>\n";
+}
+
+# move an image down (swap it with the next image)
+sub movedown {
+  my ($self, $query, $index) = @_;
+  my @images = $self->images;
+  if ($index >= 0 && $index < $#images) {
+    @images[$index+1, $index] = @images[$index, $index+1];
+    $self->{session}{images} = \@images;
+  }
+
+  my $url = $self->_fix_url($query, "$URLBASE$ENV{SCRIPT_NAME}?showimages=");
+  print  "Refresh: 0; url=\"$url\"\n";
+  print "Content-type: text/html\n\n<HTML></HTML>\n";
+}
+
+sub _fix_url {
+  my ($self, $query, $url) = @_;
+  if ($self->{keep}) {
+    for my $key (@{$self->{keep}}) {
+      for my $value ($query->param($key)) {
+       $url .= '&' . $key . '=' . CGI::escape($value);
+      }
+    }
+  }
+
+  return $url;
+}
+
+sub page {
+  my ($self) = @_;
+
+  my @images = $self->images;
+  my $image_index = -1;
+  my $imagePos = $self->imagePos;
+  my %acts;
+  %acts =
+    (
+     message=>sub { $self->{message} },
+     script => sub { $ENV{SCRIPT_NAME} },
+     iterate_image => sub { ++$image_index < @images },
+     image => sub { $images[$image_index]{$_[0]} },
+     checked => sub { $imagePos eq $_[0] ? ' checked' : '' },
+     imgtype => sub { $self->{imgtype} },
+     imgmove =>
+     sub {
+       my $html = '';
+       if ($image_index > 0) {
+        $html .= <<HTML;
+<input type=submit name="moveimgup_$image_index" value="Move Up">
+HTML
+       }
+       if ($image_index < $#images) {
+        $html .= <<HTML;
+<input type=submit name="moveimgdown_$image_index" value="Move Down">
+HTML
+       }
+       if ($html eq '') {
+         $html = '&nbsp;';
+       }
+       return $html;
+     },
+    );
+  if ($self->{extras}) {
+    for my $key (keys %{$self->{extras}}) {
+      $acts{$key} = $self->{extras}{$key}
+       unless exists $acts{$key};
+    }
+  }
+  print "Content-Type: text/html\n\n";
+  print Squirrel::Template->new(%TEMPLATE_OPTS)
+    ->show_page($TMPLDIR, $self->{template}, \%acts);
+}
+
+1;
diff --git a/site/cgi-bin/modules/Squirrel/PGP5.pm b/site/cgi-bin/modules/Squirrel/PGP5.pm
new file mode 100644 (file)
index 0000000..a822ff6
--- /dev/null
@@ -0,0 +1,104 @@
+package Squirrel::PGP5;
+
+sub new {
+  return bless {}, $_[0];
+}
+
+sub error {
+  return $_[0]->{error};
+}
+
+sub encrypt {
+  my ($self, $recips, $data, %opts) = @_;
+
+  my @recips = ref $recips ? @$recips : ( $recips );
+  my $cmd = $opts{pgp} || 'pgp';
+  $cmd .= ' ';
+  ++$opts{sign} if $opts{secretkeyid};
+  my $flags = "afe";
+  if ($opts{sign} && !$opts{passphrase}) {
+    $self->{error} = "Cannot sign without passphrase"; 
+    return 
+  }
+  
+  $flags .= "s" if $opts{sign};
+  $cmd .= "-$flags ";
+  $cmd .= "-u $opts{secretkeyid} " if $opts{secretkeyid};
+  
+  # do the deed
+  my $child = open CHILD, "-|";
+  defined $child or do { $self->{error} = "Cannot fork: $!"; return };
+  unless ($child) {
+    $ENV{PGPPASSFD} = 0 if $opts{sign};
+    print STDERR "PGP command: $cmd\n" if $opts{debug};
+    if (open PGP, "| $cmd") {
+      select(PGP); $| = 1; select(STDOUT);
+      print $opts{passphrase}, "\n" if $opts{sign};
+      print $data;
+      close PGP
+       or do { print "*ERROR* $?/$!\n"; exit 1; };
+    }
+    else {
+      print "*ERROR* $!\n";
+      exit 1;
+    }
+
+    exit 0; # finish the child
+  }
+
+  # ... and back in the parent process
+  my @data = <CHILD>;
+  print STDERR "Data out: @data\n" if $opts{debug};
+  my $result = close CHILD;
+  if (!$result) {
+    print STDERR __PACKAGE__," Error\n" if $opts{debug};
+    # something went wrong, try to figure out what
+    if ($? >> 8) {
+      print STDERR __PACKAGE__," non-zero from child\n" if $opts{debug};
+      # first child returned non-zero
+      my @errors = grep /^\*ERROR*/, @data;
+      if (@errors) {
+       
+       $self->{error} = substr($errors[0], 7);
+      }
+      else {
+       $self->{error} = "Unknown error";
+      }
+    }
+    else {
+      $self->{error} = "Unknown error: $!";
+    }
+    print STDERR __PACKAGE__," $self->{error}\n" if $opts{debug};
+    return undef;
+  }
+
+  return join('', @data);
+}
+
+1;
+
+=head1 NAME
+
+  Squirrel::PGP5
+
+=head1 SYNOPSIS
+
+  use Squirrel::PGP5;
+  my $pgp = Squirrel::PGP5->new;
+  my $data = ...;
+  my @recips = ( 'foo@bar.com' );
+  my $pass = ...; # passphase, required for sign
+  my $keyid = '9876BCED';
+  my $crypted = $pgp->encrypt(\@recips, $data, passphrase=>$pass,
+                             sign=>1, keyid=>$keyid)
+    or die "Cannot encrypt: ",$pgp->error;
+
+=head1 BUGS
+
+Doesn't attempt to overwrite copies of keys and so on.  This probably
+isn't worth the trouble in Perl, since copies of all that would have
+been in mortals passed into functions.
+
+Needs more documentation.
+
+=cut
diff --git a/site/cgi-bin/modules/Squirrel/PGP6.pm b/site/cgi-bin/modules/Squirrel/PGP6.pm
new file mode 100644 (file)
index 0000000..2cffa0b
--- /dev/null
@@ -0,0 +1,156 @@
+package Squirrel::PGP6;
+
+sub new {
+  return bless {}, $_[0];
+}
+
+sub error {
+  return $_[0]->{error};
+}
+
+sub encrypt {
+  my ($self, $recips, $data, %opts) = @_;
+
+  my @recips = ref $recips ? @$recips : ( $recips );
+  my $cmd = $opts{pgp} || 'pgp';
+  $cmd .= ' ';
+  #++$opts{sign} if $opts{secretkeyid};
+  my $flags = "feat";
+  if ($opts{sign} && !$opts{passphrase}) {
+    $self->{error} = "Cannot sign without passphrase"; 
+    return 
+  }
+  
+  $flags .= "s" if $opts{sign};
+  $cmd .= "-$flags ";
+  $cmd .= "-u$opts{secretkeyid} " if $opts{secretkeyid};
+  $cmd .= "'$_' " for @recips;
+  
+  # do the deed
+  my $child = open CHILD, "-|";
+  defined $child or do { $self->{error} = "Cannot fork: $!"; return };
+  unless ($child) {
+    $ENV{PGPPASSFD} = 0 if $opts{sign};
+    $ENV{VERBOSE} = $opts{verbose} if exists $opts{verbose};
+    if ($opts{home}) {
+      $ENV{HOME} = $opts{home};
+    }
+    else {
+      my @uinfo = getpwuid $<;
+      if (@uinfo) {
+        $ENV{HOME} = $uinfo[7];
+        print STDERR "HOME set to $ENV{HOME}\n" if $opts{debug};
+      }
+      else {
+        print STDERR "Could not get user info for $<\n" if $opts{debug};
+      }
+    }
+    print STDERR "PGP command: $cmd\n" if $opts{debug};
+    if (open PGP, "| $cmd") {
+      select(PGP); $| = 1; select(STDOUT);
+      print PGP $opts{passphrase}, "\n" if $opts{sign};
+      print PGP $data;
+      close PGP
+       or do { print "*ERROR* $?/$!\n"; exit 1; };
+    }
+    else {
+      print "*ERROR* $!\n";
+      exit 1;
+    }
+
+    exit 0; # finish the child
+  }
+
+  # ... and back in the parent process
+  my @data = <CHILD>;
+  print STDERR "Data out: @data\n" if $opts{debug};
+  my $result = close CHILD;
+  if (!$result) {
+    print STDERR __PACKAGE__," Error\n" if $opts{debug};
+    # something went wrong, try to figure out what
+    if ($? >> 8) {
+      print STDERR __PACKAGE__," non-zero from child\n" if $opts{debug};
+      # first child returned non-zero
+      my @errors = grep /^\*ERROR*/, @data;
+      if (@errors) {
+       $self->{error} = substr($errors[0], 7);
+      }
+      else {
+       $self->{error} = "Unknown error";
+      }
+    }
+    else {
+      $self->{error} = "Unknown error: $!";
+    }
+    print STDERR __PACKAGE__," $self->{error}\n" if $opts{debug};
+    return undef;
+  }
+
+  return join('', @data);
+}
+
+1;
+
+=head1 NAME
+
+  Squirrel::PGP6
+
+=head1 SYNOPSIS
+
+  use Squirrel::PGP6;
+  my $pgp = Squirrel::PGP6->new;
+  my $data = ...;
+  my @recips = ( 'foo@bar.com' );
+  my $pass = ...; # passphase, required for sign
+  my $keyid = '9876BCED';
+  my $crypted = $pgp->encrypt(\@recips, $data, passphrase=>$pass,
+                             sign=>1, keyid=>$keyid)
+    or die "Cannot encrypt: ",$pgp->error;
+
+=head1 METHODS
+
+=over 4
+
+=item $pgp->encrypt(\@recips, $data, %opts)
+
+Encrypts $data using the public keys of @recips.  %opts can contain
+the following keys:
+
+pgp - path to the pgp executable (defaults to just 'pgp')
+
+sign - the message is signed with the user's private key if this is
+true.  The passphrase must also be set.
+
+passphrase - the passphrase used to access the private key
+
+secretkeyid - the secret key used to sign the message
+
+debug - some debugging information is sent to STDERR if this is set
+
+verbose - the environment variable VERBOSE is set to this if set.
+
+home - used to set the HOME environment variable.  If this isn't set
+then the $dir result from getpwuid $< will be used.
+
+=item $pgp->error()
+
+Returns the last error seen.
+
+=back
+
+=head1 BUGS
+
+Doesn't attempt to overwrite copies of keys and so on.  This probably
+isn't worth the trouble in Perl, since copies of all that would have
+been in mortals passed into functions.
+
+Doesn't handle error returns from pgp, not that pgp6 returns much in
+the way of useful error information.
+
+Needs more documentation.
+
+=head1 SEE ALSO
+
+Squirrel::GPG(3), gpg(1)
+
+=cut
diff --git a/site/cgi-bin/modules/Squirrel/Row.pm b/site/cgi-bin/modules/Squirrel/Row.pm
new file mode 100644 (file)
index 0000000..8600eae
--- /dev/null
@@ -0,0 +1,247 @@
+package Squirrel::Row;
+require 5.005;
+use strict;
+
+use Carp;
+use DatabaseHandle 0.1;
+
+my $dh = single DatabaseHandle;
+
+sub new {
+  my ($class, @values) = @_;
+
+  my @primary = $class->primary;
+  my @columns = $class->columns;
+
+  my $self = bless { }, $class;
+
+  confess "Incorrect number of params supplied to ${class}::new, expected ",
+    scalar(@columns)," but received ",scalar(@values)
+      if @columns != @values;
+
+  @$self{@columns} = @values;
+  
+  unless (defined $self->{$primary[0]}) {
+    use Constants '$L_ID';
+    my $bases = $class->bases;
+    if (keys %$bases) {
+      keys %$bases == 1
+       or confess "I don't know how to handle more than one base for $class";
+      my ($my_col) = keys %$bases;
+      my $base_class = $bases->{$my_col}{class};
+      my $sth = $dh->{"add$base_class"}
+       or confess "No add$base_class member in DatabaseHandle";
+      
+      # extract the base class columns
+      my @base_cols = $base_class->columns;
+      my %data;
+      @data{$class->columns} = @values;
+      $sth->execute(@data{@base_cols[1..$#base_cols]})
+       or confess "Could not add $class/$base_class(undef, @data{@base_cols[1..$#base_cols]} )";
+      $self->{$primary[0]} = $self->{$my_col} =
+       $data{$my_col} = $data{$primary[0]} = $sth->{$L_ID};
+      
+      # now do this class
+      # what do we store
+      my %saved;
+      @saved{@base_cols} = @base_cols;
+      delete $saved{$my_col}; # make sure we save this
+      my @save_cols = grep !$saved{$_}, @columns;
+      $sth = $dh->{"add$class"}
+       or confess "No add$class member in DatabaseHandle";
+      $sth->execute(@data{@save_cols})
+       or confess "Could not add $class(@data{1..$#save_cols})";
+    }
+    else {
+      my $sth = $dh->{"add$class"}
+       or confess "No add$class member in DatabaseHandle";
+      my $ret = $sth->execute(@values[1..$#values]);
+      $ret != 0
+       or confess "Could not add $class(undef, @values[1..$#values]) to database: ",$sth->errstr;
+      $self->{$primary[0]} = $sth->{$L_ID};
+    }
+  }
+
+  confess "Undefined primary key fields in ${class}::new"
+    if grep !defined, @$self{@primary};
+
+  my $foreign = $self->foreign;
+  for my $key (keys %$foreign) {
+    my $module = $foreign->{$key}{module};
+    my $version = $foreign->{$key}{version};
+
+    next unless defined $module;
+
+    next if !defined($self->{$key}) && exists $foreign->{$key}{null};
+
+    require $module.'.pm';
+
+    $module->VERSION($version) if defined $version;
+
+    my $mod = $module->new;
+
+    confess "Bad FK field $class($key) ($self->{$key})"
+       unless $self->{$key} = $mod->getByPkey($self->{$key});
+  }
+
+  $self->{pkey} = join("", @$self{@primary});
+  $self->{changed} = 0;
+
+  $self;
+}
+
+sub foreign {
+  return {};
+}
+
+sub primary {
+  return qw(id);
+}
+
+sub bases {
+  return {};
+}
+
+sub save {
+  my $self = shift;
+  my %saved;
+  my $bases = $self->bases;
+  if (keys %$bases) {
+    # save to the bases
+    # this should probably recurse at some point
+    for my $base_key (keys %$bases) {
+      # we have bases, update them
+      my $base_class = $bases->{$base_key}{class};
+      my @base_cols = $base_class->columns;
+      my $sth = $dh->{'replace'.$base_class}
+       or confess "No replace$base_class member in DatabaseHandle";
+      my @data;
+      for my $col (@base_cols) {
+       push(@data, ref $self->{$col} ? $self->{$col}{pkey} : $self->{$col});
+       ++$saved{$col};
+      }
+      $sth->execute(@data)
+       or confess "Cannot save $base_class part of ",ref $self,":",
+         $sth->errstr;
+    }
+  }
+
+  my $sth = $dh->{'replace'.ref $self}
+    or confess "No replace",ref $self," member in DatabaseHandle";
+  my @data;
+  for my $col ($self->columns) {
+    push(@data, ref $self->{$col} ? $self->{$col}{pkey} : $self->{$col})
+      unless $saved{$col};
+  }
+  $sth->execute(@data)
+    or confess "Cannot save ",ref $self,":",$sth->errstr;
+
+  $self->{changed} = 0;
+}
+
+sub remove {
+  my $self = shift;
+  my $sth = $dh->{'delete'.ref($self)};
+  $sth->execute(@$self{$self->primary});
+
+  # BUG: this should invalidate the cache
+}
+
+sub set {
+  my ($self, $name, $value) = @_;
+
+  exists $self->{$name}
+    or do { warn "Attempt to set column '$name' in ",ref $self; return };
+  $self->{$name} = $value;
+  ++$self->{changed};
+
+  return $value;
+}
+
+sub AUTOLOAD {
+  use vars '$AUTOLOAD';
+  (my $calledName = $AUTOLOAD) =~ s/^.*:://;
+  for ($calledName) {
+    /^set(.+)$/ && exists($_[0]->{lcfirst $1})
+      && return $_[0]->set(lcfirst $1, $_[1]);
+  }
+  confess qq/Can't locate object method "$calledName" via package "/,
+    ref $_[0],'"';
+}
+
+# in case someone tries AUTOLOAD tricks
+sub DESTROY {
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+  Squirrel::Row - base for rows
+
+=head1 DESCRIPTION
+
+A base class for implementing table row wrapper classes.
+
+Based on code by Jason.
+
+=head1 INTERFACE
+
+=over 4
+
+=item $row = Class->new(@values)
+
+Class is some derived class.
+
+Create a new object of that class.
+
+=item $row->columns()
+
+Return a list of column names in the table.  No default.
+
+=item $row->foreign()
+
+Returns a hashref for which the keys are column names and the values
+are hashrefs with the following values:
+
+=over 4
+
+=item module
+
+the table class
+
+=item version
+
+the minimum version number
+
+=item null
+
+the column allows NULL
+
+=back
+
+Returns an empty list by default.
+
+The older code used column numbers, but was always looking up the
+column name in the columns array, so it seemed a reasonable changed to
+use the names instead.  It's also more stable against schema changes.
+(And it saves me having to count columns.)
+
+=item $row->primary()
+
+Returns a list of the names of the columns that make up the primary key.
+
+Defaults to ('id').
+
+The older code returned column numbers, but was always looking up the
+column names in the columns array.
+
+=back
+
+=NAME SEE ALSO
+
+Squirrel::Table(3), perl(1)
+
+=cut
diff --git a/site/cgi-bin/modules/Squirrel/Table.pm b/site/cgi-bin/modules/Squirrel/Table.pm
new file mode 100644 (file)
index 0000000..40cbf62
--- /dev/null
@@ -0,0 +1,242 @@
+package Squirrel::Table;
+
+use vars qw($VERSION);
+use Carp;
+use strict;
+
+$VERSION = 0.1;
+
+use DatabaseHandle;
+
+my $dh = single DatabaseHandle;
+
+# no caching is performed if this is zero
+my $cache_timeout = 2; # seconds
+
+# cache of loaded tables
+# this prevents us from reloading the table so often
+# key is the table class name, value is a hash ref with two keys:
+#  table - the table object
+#  when - time value when the object was created.
+# Table::add() invalidates the cache for the given class
+my %cache;
+
+sub new {
+  my ($class, $nocache) = @_;
+
+  return $cache{$class}{table}
+    if !$nocache
+      && exists $cache{$class} 
+      && defined $cache{$class}{time}
+      && $cache{$class}{time}+$cache_timeout >= time;
+
+  my $sth = $dh->{$class}
+    or confess "No $class member in DatabaseHandle";
+  $sth->execute
+    or confess "Cannot execute $class handle from DatabaseHandle:",DBI->errstr;
+
+  my %coll;
+  my @order;
+  my $rowClass = $class->rowClass;
+  require $rowClass.".pm";
+  while (my $row = $sth->fetchrow_arrayref) {
+    my $item = $rowClass->new(@$row);
+    $coll{$item->{pkey}} = $item;
+    push(@order, $item);
+    
+  }
+
+  my $result = bless { ptr=>-1, coll=>\%coll, order=>\@order }, $class;
+
+  if ($cache_timeout) {
+    $cache{$class}{table} = $result;
+    $cache{$class}{when} = time;
+  }
+
+  return $result;
+}
+
+sub EOF {
+  my $self = shift;
+
+  ++$self->{ptr} >= @{$self->{order}};
+}
+
+sub getNext {
+  my $self = shift;
+  return $self->{order}[$self->{ptr}];
+}
+
+sub getByPkey {
+  my ($self, @values) = @_;
+  if (ref($self)) {
+    return $self->{coll}{join "", @values};
+  }
+  else {
+    # try to get row by key
+    my $rowClass = $self->rowClass;
+    require $rowClass . ".pm";
+    my $member = "get${rowClass}ByPkey";
+    my $sth = $dh->{$member}
+      or confess "No $member in DatabaseHandle";
+    $sth->execute(@values)
+      or confess "Cannot execute $member handle from DatabaseHandle:", DBI->errstr;
+    # should only be one row
+    if (my $row = $sth->fetchrow_arrayref) {
+      return $rowClass->new(@$row);
+    }
+    else {
+      return undef;
+    }
+  }
+}
+
+sub add {
+  my ($self, @data) = @_;
+
+  require $self->rowClass.".pm";
+  my $item = $self->rowClass->new(undef, @data);
+
+  # if called as an instance method
+  if (ref($self)) {
+    delete $cache{ref $self};
+    $self->{coll}{$item->{pkey}} = $item;
+    push(@{$self->{order}}, $item);
+  }
+  else {
+    delete $cache{ref $self};
+  }
+
+  return $item;
+}
+
+# get all values in a particular column
+sub getAll {
+  my ($self, $column) = @_;
+  my @values = map { $_->{$column} } @{$self->{order}};
+
+  return wantarray ? @values : \@values;
+}
+
+# column grep
+sub getBy {
+  my ($self, $column, $value) = @_;
+
+  my @results;
+  if (ref($self) && UNIVERSAL::isa($self, __PACKAGE__)) {
+    # this is an object with the rows already loaded
+    for my $row (@{$self->{order}}) {
+      my $comp = ref $row->{$column} ? $row->{$column}->getPkey : $row->{$column};
+      push @results, $row if $comp eq $value;
+    }
+  }
+  else {
+    # ask the database directly
+    my $rowClass = $self->rowClass;
+    require $rowClass . ".pm";
+    my $member = "get${rowClass}By\u$column";
+    my $sth = $dh->{$member}
+      or confess "No $member in DatabaseHandle";
+    $sth->execute($value)
+      or confess "Cannot execute $member from DatabaseHandle: ",DBI->errstr;
+    while (my $row = $sth->fetchrow_arrayref) {
+      push(@results, $rowClass->new(@$row));
+    }
+  }
+
+  return wantarray ? @results : $results[0];
+}
+
+# a list of all rows in select order
+sub all {
+  my $self = shift;
+  return @{$self->{order}};
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Base class for tables.
+
+=head1 DESCRIPTION
+
+This needs more documentation.
+
+=head1 IMPLEMENT IN THE BASE
+
+=over 4
+
+=item rowClass()
+
+Returns the name of the class implementing the rows for this class.
+
+=back
+
+=head1 IMPLEMENT IN DatabaseHandle
+
+=head1 METHODS
+
+Some methods can be used as both class and instance methods.
+
+In these cases when used as a class method they ask the database
+directly for the information.  This requires that appropriate keys be
+defined in the DatabaseHandle object.
+
+In the examples SomeTable is used as the name of the table class
+derived from Squirell::Table.
+
+=over 4
+
+=item $table = SomeTable->new
+
+Loads the contents of the table into memory.
+
+=item until ($table->EOF) { ... }
+
+Bumps the index into the table, returns TRUE if we've passed the end
+of the table.
+
+=item $row = $table->getNext
+
+Gets the currently indexed item in the table.
+
+=item $row = $table->getByPkey(@values)
+
+=item $row = SomeTable->getByPkey(@values)
+
+Retrieves the specified row from the database.
+
+For the class method version to work you must have a statement handle
+in the DatabaseHandle object called get${rowClass}ByPkey.
+
+=item $row = $table->add(@data)
+
+=item $row = SomeTable->add(@data)
+
+Adds a row to the table.  @data must contain all except the primary key.
+
+=item @rows = $table->getAll($column)
+
+Returns a list containing that column for each row in the table.
+
+Returns an array ref if called in a scalar context.
+
+=item @rows = $table->getBy($column, $value)
+
+=item @rows = SomeTable->getBy($column, $value)
+
+Returns any rows where the given column has that value.
+
+Returns the first element of the list if called in scalar context
+(though it still retrieves the whole lot.)
+
+For the class method form to work the DatabaseHandle object must have
+a member "get${rowClass}By\u$column".
+
+=back
+
+=cut
+
diff --git a/site/cgi-bin/modules/Squirrel/Template.pm b/site/cgi-bin/modules/Squirrel/Template.pm
new file mode 100644 (file)
index 0000000..6ab71a0
--- /dev/null
@@ -0,0 +1,326 @@
+package Squirrel::Template;
+use vars qw($VERSION);
+use strict;
+use Carp;
+
+$VERSION="0.04";
+
+sub new {
+  my ($class, %opts) = @_;
+
+  return bless \%opts, $class;
+}
+
+sub perform {
+  my ($self, $acts, $func, $args, $orig) = @_;
+
+  my $fmt;
+  if ($acts->{_format} && $args =~ s/\|([\w%]+)\s*$//) {
+    $fmt = $1;
+  }
+
+  if (exists $acts->{$func}) {
+    $args = '' unless defined $args;
+    $args =~ s/^\s+|\s+$//g;
+    my $value = $acts->{$func}->($args);
+    defined $value
+      or return "** function $func $args returned undef **";
+    return $fmt ? $acts->{_format}->($value, $fmt) : $value;
+  }
+  for my $match (keys %$acts) {
+    if ($match =~ m(^/(.+)/$)) {
+      my $re = $1;
+      if ($func =~ /$re/) {
+       $args =~ s/^\s+|\s+$//g;
+       my $value = $acts->{$match}->($func, $args);
+       defined $value
+         or return "** function $func $args returned undef **";
+       return $fmt ? $acts->{_format}->($value, $fmt) : $value;
+      }
+    }
+  }
+  if ($func eq 'summary') {
+    my $size = 80;
+    my $temp = $args;
+    $temp =~ s/^\s+|\s+$//g;
+    $size = $1 if $temp =~ s/^(\d+)\s+//;
+    my ($newfunc, $newargs) = split /\s+/, $temp, 2;
+    $newargs = '' if !defined $newargs;
+    if (exists $acts->{$newfunc}
+       and defined(my $value = $acts->{$newfunc}->($newargs))) {
+      # work out a summary
+      return $value if length($value) < $size;
+      $value = substr($value, 0, $size);
+      $value =~ s/\s+\S*$/.../;
+      return $value;
+    }
+    # otherwise fall through
+  }
+  return $self->{verbose} ? "** unknown function $func **" : $orig;
+}
+
+sub iterate {
+  my ($self, $name, $args, $input, $sep, $acts, $orig) = @_;
+
+  $args = '' unless defined $args;
+  $sep = '' unless defined $sep;
+
+  if (my $entry = $acts->{"iterate_$name"}) {
+    $args =~ s/^\s+|\s+$//g;
+    my $reset;
+    $reset->($args) if $reset = $acts->{"iterate_${name}_reset"};
+    my $result = '';
+    while ($entry->($name, $args)) {
+      $result .= $self->replace_template($sep, $acts) if length $result;
+      $result .= $self->replace_template($input, $acts);
+    }
+    return $result;
+  }
+  else {
+    return $self->{verbose} ? "** No iterator $name **" : $orig;
+  }
+}
+
+sub cond {
+  my ($self, $name, $args, $true, $false, $acts, $orig) = @_;
+
+  if (exists $acts->{"if$name"}) {
+    return $acts->{"if$name"}->($args) ? $true : $false;
+  }
+  elsif (exists $acts->{lcfirst $name}) {
+    return $acts->{lcfirst $name}->($args) ? $true : $false;
+  }
+  else {
+    return $orig;
+  }
+}
+
+sub replace_template {
+  my ($self, $template, $acts, $iter) = @_;
+
+  defined $template
+    or confess "Template must be defined";
+
+  # add any wrappers
+  if ($self->{template_dir}) {
+    my $wrap_count = 0;
+    while ($template =~ /^(\s*<:\s*wrap\s+(\S+)\s*:>)/i
+           && -e "$self->{template_dir}/$2"
+           && ++$wrap_count < 10) {
+      my $wrapper = "$self->{template_dir}/$2";
+      if (open WRAPPER, "< $wrapper") {
+        my $wraptext = do { local $/; <WRAPPER> };
+        close WRAPPER;
+        $template = substr($template, length $1);
+        $wraptext =~ s/<:\s*wrap\s+here\s*:>/$template/i
+          and $template = $wraptext
+            or last;
+      }
+    }
+  }
+
+  # the basic iterator
+  if ($iter && 
+      (my ($before, $row, $after) =
+      $template =~ m/^(.*)
+           <:\s+iterator\s+begin\s+:>
+            (.*)
+           <:\s+iterator\s+end\s+:>
+            (.*)/sx)) {
+    until ($iter->EOF) {
+      my $temp = $row;
+      $temp =~ s/(<:\s*(\w+)(?:\s+([^:]*?))\s*:>)/ $self->perform($acts, $2, $3, $1) /egx;
+      $before .= $temp;
+    }
+    $template = $before . $after;
+  }
+
+  # more general iterators
+  $template =~ s/(<:\s*iterator\s+begin\s+(\w+)(?:\s+([^:]*))?\s*:>
+                  (.*?)
+                   (?: 
+                    <:\s*iterator\s+separator\s+\2\s*:>
+                      (.*?)
+                    ) ?
+                 <:\s*iterator\s+end\s+\2\s*:>)/
+                   $self->iterate($2, $3, $4, $5, $acts, $1) /segx;
+
+  # conditionals
+  my $nesting = 0; # prevents loops if result is an if statement
+  1 while $template =~ s/(<:\s*if\s+(\w+)(?:\s+([^:]*))?\s*:>
+                          (.*?)
+                         <:\s*or\s+\2\s*:>
+                          (.*?)
+                         <:\s*eif\s+\2\s*:>)/
+                        $self->cond($2, $3, $4, $5, $acts, $1) /sgex
+                         && ++$nesting < 5;
+  $template =~ s/(<:\s*if(\w+)(?:\s+([^:]*))?\s*:>
+                  (.*?)
+                 <:\s*or\s*:>
+                  (.*?)
+                 <:\s*eif\s*:>)/
+                $self->cond($2, $3, $4, $5, $acts, $1) /sgex;
+
+  $template =~ s/(<:\s*(\w+)(?:\s+([^:]*))?\s*:>)/ 
+    $self->perform($acts, $2, $3, $1) /egx;
+
+  return $template;
+}
+
+sub show_page {
+  my ($self, $base, $page, $acts, $iter) = @_;
+
+  $acts ||= {};
+
+  my $file = "$base/$page";
+  open TMPLT, "< $file"
+    or die "Cannot open template $file: $!";
+  my $template = do { local $/; <TMPLT> };
+  close TMPLT;
+
+  return $self->replace_template($template, $acts, $iter);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+  Squirrel::Template - simple templating system
+
+=head1 SYNOPSIS
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item $templ = Squirrel::Template->new(%opts);
+
+Create a new templating object.
+
+Possible options are:
+
+=over 4
+
+=item verbose
+
+If a tag isn't found in the actions then it is replaced with an error
+message rather than being left in place.
+
+=item template_dir
+
+Used by the wrapper mechanism to find wrapper templates.  See
+L<WRAPPING> below.
+
+=back
+
+=item $text = $templ->show_page($base, $template, $acts, $iter)
+
+Performs template replacement on the text from the file $template in
+directory $base.
+
+=item $text = $templ->replace_template($intext, $acts, $iter)
+
+Performs template replacement on $intext.
+
+=back
+
+=head1 TEMPLATES
+
+=over 4
+
+=item <: name args :>
+
+Replaced with $acts->{name}->(args)
+
+=item <: iterator begin name args :> text <: iterator separator name :> separator <: iterator end name :>
+
+Replaced with repeated templating of text separated by separator while
+$acts->{iterator_name}->($args, $name) is true.
+
+
+=item <: iterator begin name args :> text <: iterator end name :>
+
+Replaced with repeated templating of text while
+$acts->{iterate_name}->($args, $name) is true.
+
+This may be nested or repeated.
+
+=item <: iterator begin :> text <: iterator end :>
+
+Replaced with repeated templating of text while $iter->EOF is true.
+
+=item <: ifname args :> true <: or :> false <: eif :>
+
+Emits true if $acts->{ifname}->($args) is true, otherwise the false text.
+
+=item <: if name args :> true <: or name :> false <: eif name :>
+
+Emits true if $acts->{ifname}->($args) is true, otherwise the false text.
+
+Has the advantage that it can be nested (the other form doesn't
+support nesting - this isn't a proper parser.
+
+=back
+
+=head1 WRAPPING
+
+If you define the template_dir option when you create your templating
+object, then a mechnism to wrap the current template with another is
+enabled.
+
+For the wrapping to occur:
+
+=over 4
+
+=item *
+
+The template specified in the call to replace_template() or
+show_page() needs to start with:
+
+<: wrap I<templatename> :>
+
+=item *
+
+The template specified in the <: wrap ... :> tag must exist in the
+directory specified by the I<template_dir> option.
+
+=item *
+
+The template specified in the <: wrap ... :> tag must contain a:
+
+   <: wrap here :>
+
+tag.
+
+=back
+
+The current template text is then replaced with the contents of the
+template specified by I<templatename>, with the <: wrap here :>
+replaced by the original template text.
+
+This is then repeated for the new template text.
+
+=head1 SPECIAL ACTIONS
+
+So far there's just one:
+
+=over 4
+
+=item _format
+
+If the _format action is defined in your $acts then if a function tag
+has |text at the end of it then the function is evaluated, and the
+resulting text and the text after the | is passed to the format
+function.
+
+=back
+
+=head1 SEE ALSO
+
+  Squirrel::Row(3p), Squirel::Table(3p)
+
+=cut
diff --git a/site/cgi-bin/search.pl b/site/cgi-bin/search.pl
new file mode 100755 (executable)
index 0000000..3617490
--- /dev/null
@@ -0,0 +1,391 @@
+#!/usr/bin/perl -w
+
+use strict;
+use CGI qw(:standard);
+use lib 'modules';
+use Articles;
+use DatabaseHandle;
+use Squirrel::Template;
+use Constants qw($TMPLDIR @SEARCH_EXCLUDE @SEARCH_INCLUDE $SEARCH_ALL);
+use Carp;
+
+my $results_per_page = 10;
+
+my $dh = DatabaseHandle->single;
+
+my $words = param('q');
+my $section = param('s');
+my $date = param('d');
+$section = '' if !defined $section;
+$date = 'ar' if ! defined $date;
+my @results;
+my @terms; # terms as parsed by the search engine
+my $case_sensitive;
+if (defined $words && length $words) {
+  $case_sensitive = $words ne lc $words;
+  @results = getSearchResult($words, $section, $date, \@terms);
+}
+else { 
+  $words = ''; # so we don't return junk for the form default
+}
+
+my $page_count = int((@results + $results_per_page - 1)/$results_per_page);
+
+my $page_number = param('page') || 1;
+$page_number = $page_count if $page_number > $page_count;
+
+my $admin = param('admin');
+$admin = 0 if !defined $admin;
+
+my @articles;
+if (@results) {
+  my $articles_start = ($page_number-1) * $results_per_page;
+  my $articles_end = $articles_start + $results_per_page-1;
+  $articles_end = $#results if $articles_end >= @results;
+
+  for my $id (@results[$articles_start..$articles_end]) {
+    my $article = Articles->getByPkey($id)
+      or die "Cannot retrieve article $id\n";
+    push(@articles, $article);
+  }
+}
+
+# make an array of hashes (to preserve order)
+my %excluded;
+@excluded{@SEARCH_EXCLUDE} = @SEARCH_EXCLUDE;
+my %included;
+@included{@SEARCH_INCLUDE} = @SEARCH_INCLUDE;
+my @sections = map { { $_->{id} => $_->{title} } } 
+                    sort { $b->{displayOrder} <=> $a->{displayOrder} }
+                      grep { ($_->{listed} || $included{$_->{id}}) 
+                                && !$excluded{$_->{id}} }
+                        Articles->getBy('level', 1);
+unshift(@sections, { ""=>$SEARCH_ALL });
+my %sections = map { %$_ } @sections;
+# now a list of values ( in the correct order
+@sections = map { keys %$_ } @sections;
+
+my $page_num_iter = 0;
+
+my $article_index = -1;
+my $result_seq = ($page_number-1) * $results_per_page;
+my $excerpt;
+my $keywords;
+my $words_re_str = '\b('.join('|', @terms).')\b';
+my $words_re = qr/$words_re_str/i;
+my %acts;
+%acts =
+  (
+   iterate_results => 
+   sub { 
+     ++$result_seq;
+     ++$article_index;
+     if ($article_index < @articles) {
+       my $found = 0;
+       $excerpt = excerpt($articles[$article_index], \$found, @terms);
+
+       # match against the keywords
+       $keywords = $articles[$article_index]{keyword};
+       $keywords =~ s!$words_re!<b>$1</b>!g or $keywords = '';
+
+       return 1;
+     }
+     else {
+       return 0;
+     }
+   },
+   article => 
+   sub { 
+     return CGI::escapeHTML($articles[$article_index]{$_[0]});
+   },
+   date =>
+   sub {
+     my ($func, $args) = split ' ', $_[0];
+     use POSIX 'strftime';
+     exists $acts{$func}
+       or return "** $func not found for date **";
+     my $date = $acts{$func}->($args)
+       or return '';
+     my ($year, $month, $day) = $date =~ /(\d+)\D+(\d+)\D+(\d+)/;
+     $year -= 1900;
+     --$month;
+     return strftime('%d-%b-%Y', 0, 0, 0, $day, $month, $year, 0, 0);
+   },
+   keywords => sub { $keywords },
+   ifResults => sub { scalar @results; },
+   ifSearch => sub { defined $words and length $words },
+   dateSelected => sub { $_[0] eq $date ? 'selected' : '' },
+   excerpt => 
+   sub { 
+     return $excerpt;
+   },
+   articleurl => 
+   sub {
+     my $name = $admin ? "admin" : "link";
+     return $articles[$article_index]{$name};
+   },
+   count => sub { scalar @results },
+   multiple => sub { @results != 1 },
+   terms => sub { CGI::escapeHTML($words) },
+   resultSeq => sub { $result_seq },
+   list => sub { popup_menu(-name=>'s',
+                           -values=>\@sections,
+                           -labels=>\%sections) },
+   
+   # result pages
+   iterate_pages =>
+   sub {
+     return ++$page_num_iter <= $page_count;
+   },
+   page => sub { $page_num_iter },
+   ifCurrentPage => sub { $page_num_iter == $page_number },
+   pageurl => 
+   sub {
+     $ENV{SCRIPT_NAME} . "?q=" . CGI::escape($words) . 
+       "&s=" . CGI::escape($section) .
+        "&d=" . CGI::escape($date) .
+          "&page=".$page_num_iter;
+   },
+  );
+
+print "Content-Type: text/html\n\n";
+my $templ = Squirrel::Template->new();
+print $templ->show_page($TMPLDIR, "search.tmpl", \%acts);
+
+sub getSearchResult {
+  my ($words, $section, $date, $terms) = @_;
+
+  # canonical form
+  #$words = lc $words;
+  $words =~ s/^\s+|\s+$//g;
+
+  my @terms;
+  while ($words =~ /\G\s*"([^"]+)"/gc
+        || $words =~ /\G\s*'([^']+)'/gc
+        || $words =~ /\G\s*(\S+)/gc) {
+    push(@terms, $1);
+  }
+
+  # if the user entered a plain multi-word phrase
+  if ($words !~ /["']/ && $words =~ /\s/) {
+    # treat it as if they entered it in quotes as well
+    # giving articles with that phrase an extra score
+    push(@terms, $words);
+  }
+
+  my %scores;
+  my $sth = $dh->{searchIndex};
+  my %terms;
+  for my $term (@terms) {
+    $sth->execute($term)
+      or die "Could not execute search: ",$sth->errstr;
+
+    while (my $row = $sth->fetchrow_arrayref) {
+      my @ids = split ' ', $row->[1];
+      my @scores = split ' ', $row->[3];
+      if ($section) {
+       # only for the section requested
+       my @sections = split ' ', $row->[2];
+       my @keep = grep { $sections[$_] == $section } 0..$#sections;
+       @ids = @ids[@keep];
+       @scores = @scores[@keep];
+      }
+      for my $index (0..$#ids) {
+       $scores{$ids[$index]} += $scores[$index];
+      }
+    }
+  }
+
+  return () if !keys %scores;
+
+  # make sure we match the other requirements
+  my $sql = "select id from article where find_in_set(id, ?) <> 0";
+  SWITCH: for ($date) {
+    $_ eq 'ar' # been released
+      && do {
+       $sql .= " and NOW() between release and expire";
+       last SWITCH;
+      };
+    /^r(\d+)$/ # released in last N days
+      && do {
+       $sql .= " and release > date_sub(now(), INTERVAL $1 DAY)";
+       last SWITCH;
+      };
+    /^e(\d+)$/ # expired in last N days
+      && do {
+       $sql .= " and expire > date_sub(now(), INTERVAL $1 DAY) 
+                    and expire <= now() ";
+       last SWITCH;
+      };
+    $_ eq 'ae'
+      && do {
+       $sql .= " and expire < now()";
+       last SWITCH;
+       };
+  }
+  my $set = join(',', keys %scores);
+  $sth = $dh->{dbh}->prepare($sql)
+    or die "Error preparing $sql: ",$dh->{dbh}->errstr;
+
+  $sth->execute($set)
+    or die "Cannot execute $sql($set): ",$sth->errstr;
+
+  my @ids;
+  my $row;
+  push(@ids, $row->[0]) while $row = $sth->fetchrow_arrayref;
+
+  @ids = sort { $scores{$b} <=> $scores{$a} } @ids;
+
+  @$terms = @terms;
+
+  return @ids;
+}
+
+my %gens;
+
+sub excerpt {
+  my ($article, $found, @terms) = @_;
+
+  my $generator = $article->{generator};
+
+  $generator =~ /\S/ or confess "generator for $article->{id} is blank";
+
+  eval "use $generator";
+  confess "Cannot use $generator: $@" if $@;
+
+  $gens{$generator} ||= $generator->new(admin=>$admin);
+
+  return $gens{$generator}->excerpt($article, $found, $case_sensitive, @terms);
+}
+
+__END__
+
+=head1 NAME
+
+  search.pl - CGI script for searching for articles.
+
+=head1 DESCRIPTION
+
+This is the basic search engine for BSE.  It uses F<search.tmpl>
+(generated from F<search_base.tmpl>) to format it's result pages.
+
+=head1 TAGS
+
+Please note that these tags are replace once the actual search is
+done.  The tags defined in L<templates/"Base tags"> are replaced when
+you choose I<Generate static pages> from the admin page.
+
+=over 4
+
+=item iterator ... results
+
+Iterates over the articles for the current page of results.
+
+=item article I<field>
+
+Access to fields in the current search result article.
+
+=item date I<which> I<field>
+
+Formats the given field of the tag I<which> for display as a date.
+
+=item keywords
+
+Keywords for the current result article, if any keywords matches the
+requested search.
+
+=item ifResults
+
+Conditional tag, true if the search found any matching articles.
+
+=item ifSearch
+
+Conditional tag, true if the user entered any search terms.
+
+=item dateSelected I<datevalue>
+
+The date value chosen by the user for the last search.  Used in a
+<select> HTML tag to have the date field select the last value chosen
+by the user.
+
+=item excerpt
+
+An excerpt of the body of the current search result, with search terms
+highlighted.
+
+=item articleurl
+
+A link to the current search result article, taking admin mode into
+account.
+
+=item count
+
+The total number of matches found.
+
+=item ifMultiple
+
+Conditional tag, true if more than one match was found.  This can be
+used to improve the wording of descriptions of the search results.
+
+=item terms
+
+The entered search terms.
+
+=item resultSeq
+
+The number of the current search result (ie. the first found is 1, etc).
+
+=item list
+
+A drop-down list of searchable sections.
+
+=item iterator ... pages
+
+Iterates over page numbers of search results.
+
+=item page
+
+The current page number within the page number iterator.
+
+=item ifCurrentPage
+
+Conditional tag, true if the page in the page number iterator is the
+displayed page of search results.  This can be used for formatting the
+current page number differently (and not making it a link.)
+
+=item pageurl
+
+A link to the current page in the page number iterator.
+
+=back
+
+B<An example>
+
+ ...
+ <input type=text name=s value="<:terms:>">
+ ...
+
+ <:if Search:>
+ <:if Results:>
+  <dl>
+  <:iterator begin results:>
+  <dt><:resultSeq:> <a href="<:article url:>"><:article title:></a>
+  <dd><:excerpt:>
+  <:iterator end results:>
+  </dl>
+  <:iterator begin pages:>
+   <:if CurrentPage:>
+    <b><:page:></b>
+   <:or CurrentPage:>
+    <a href="<:pageurl:>"><:page:></a>
+   <:eif CurrentPage:>
+  <:iterator separator pages:>
+  |
+  <:iterator end pages:>
+ <:or Results:>
+ No articles matches your search.
+ <:eif Results:>
+ <:or Search:>
+ <:eif Search:>
+
+=cut
diff --git a/site/cgi-bin/shop.pl b/site/cgi-bin/shop.pl
new file mode 100755 (executable)
index 0000000..27ca237
--- /dev/null
@@ -0,0 +1,764 @@
+#!/usr/bin/perl -w
+use strict;
+use lib 'modules';
+use CGI ':standard';
+use CGI::Carp 'fatalsToBrowser';
+use Products;
+use Product;
+use Constants qw(:shop $TMPLDIR %EXTRA_TAGS $CGI_URI);
+use Squirrel::Template;
+use Apache::Session;
+use Squirrel::ImageEditor;
+use CGI::Cookie;
+use Apache::Session::MySQL;
+
+my $subject = $SHOP_MAIL_SUBJECT;
+
+# our PGP passphrase
+my $passphrase = $SHOP_PASSPHRASE;
+
+# the class we use to perform encryption
+# we can change this to switch between GnuPG and PGP
+my $crypto_class = $SHOP_CRYPTO;
+
+# id of the private key to use for signing
+# leave as undef to use your default key
+my $signing_id = $SHOP_SIGNING_ID;
+
+# location of sendmail
+my $sendmail = $SHOP_SENDMAIL;
+
+# location of PGP
+my $pgpe = $SHOP_PGPE;
+my $pgp = $SHOP_PGP;
+my $gpg = $SHOP_GPG;
+
+my $from = $SHOP_FROM;
+
+my $toName = $SHOP_TO_NAME;
+my $toEmail= $SHOP_TO_EMAIL;
+
+#my $opts = '-t -odi';
+my $opts = '-t';
+
+# Lifetime (in hours _OR_ minutes) of the shopping cart cookie.
+# Value can be in minutes (append an 'm') or hours (append an 'h').
+my $lifetime = '+3h';
+my $path = $CGI_URI . '/';
+
+# maximum age of shopping cart cookie
+my $max_cookie_age = "+3h";
+
+my %cookies = fetch CGI::Cookie;
+my $sessionid;
+$sessionid = $cookies{sessionid}->value if exists $cookies{sessionid};
+my %session;
+
+my $dh = single DatabaseHandle;
+eval {
+  tie %session, 'Apache::Session::MySQL', $sessionid,
+    {
+     Handle=>$dh->{dbh},
+     LockHandle=>$dh->{dbh}
+    };
+};
+if ($@ && $@ =~ /Object does not exist/) {
+  # try again
+  undef $sessionid;
+  tie %session, 'Apache::Session::MySQL', $sessionid,
+    {
+     Handle=>$dh->{dbh},
+     LockHandle=>$dh->{dbh}
+    };
+}
+unless ($sessionid) {
+  # save the new sessionid
+  print "Set-Cookie: ",
+    CGI::Cookie->new(-name=>'sessionid', -value=>$session{_session_id}, 
+                    -expires=>$lifetime),"\n";
+}
+
+# this shouldn't be necessary, but it stopped working elsewhere and this
+# fixed it
+END {
+  untie %session;
+}
+
+if (!exists $session{cart}) {
+  $session{cart} = [];
+}
+
+# the keys here are the names of the buttons on the various forms
+# we also have 'delete_<number>' buttons.
+my %steps =
+  (
+   add=>\&add_item,
+   cart=>\&show_cart,
+   checkout=>\&checkout,
+   recalc=>\&recalc,
+   purchase=>\&purchase,
+  );
+
+for my $key (keys %steps) {
+  if (param($key)) {
+    $steps{$key}->();
+    exit;
+  }
+}
+
+for my $key (param()) {
+  if ($key =~ /^delete_(\d+)/) {
+    remove_item($1);
+    exit;
+  }
+}
+
+show_cart();
+
+sub add_item {
+  my $addid = param('id');
+  my $quantity = param('quantity');
+  my $product;
+  $product = Products->getByPkey($addid) if $addid;
+  $product or return show_cart(); # oops
+  
+  # the product must be non-expired and listed
+  my $today = epoch_to_sql(time);
+  $product->{release} le $today and $today le $product->{expire}
+    or return show_cart();
+  $product->{listed} or return show_cart();
+
+  # we need a natural integer quantity
+  $quantity =~ /^\d+$/
+    or return show_cart();
+
+  my @cart = @{$session{cart}};
+  # if this is is already present, replace it
+  @cart = grep { $_->{productId} ne $addid } @cart;
+  push(@cart, { productId => $addid, units => $quantity, 
+               price=>$product->{retailPrice} });
+  $session{cart} = \@cart;
+  show_cart();
+}
+
+sub total {
+  my ($cart) = @_;
+
+  my $total = 0;
+  for my $item (@$cart) {
+    $total += $item->{units} * $item->{price};
+  }
+
+  return $total;
+}
+
+sub show_cart {
+  my @cart = @{$session{cart}};
+  my @cart_prods = map { Products->getByPkey($_->{productId}) } @cart;
+  my $item_index = -1;
+
+  my %acts;
+  %acts =
+    (
+     iterate_items => sub { ++$item_index < @cart },
+     item => 
+     sub { $cart[$item_index]{$_[0]} || $cart_prods[$item_index]{$_[0]} },
+     index => sub { $item_index },
+     total => sub { total(\@cart) },
+     money =>
+     sub {
+       my ($func, $args) = split ' ', $_[0], 2;
+       $acts{$func} || return "<: money $_[0] :>";
+       return sprintf("%.02f", $acts{$func}->($args)/100);
+     },
+     count => sub { scalar @cart },
+    );
+  page('cart.tmpl', \%acts);
+}
+
+sub update_quantities {
+  my @cart = @{$session{cart}};
+  for my $index (0..$#cart) {
+    my $new_quantity = param("quantity_$index");
+    if (defined $new_quantity) {
+      if ($new_quantity =~ /^\s*(\d+)/) {
+       $cart[$index]{units} = $1;
+      }
+      elsif ($new_quantity =~ /^\s*$/) {
+       $cart[$index]{units} = 0;
+      }
+    }
+    
+  }
+  @cart = grep { $_->{units} != 0 } @cart;
+  $session{cart} = \@cart;
+}
+
+sub recalc {
+  update_quantities();
+  show_cart();
+}
+
+sub remove_item {
+  my ($index) = @_;
+  my @cart = @{$session{cart}};
+  if ($index >= 0 && $index < @cart) {
+    splice(@cart, $index, 1);
+  }
+  $session{cart} = \@cart;
+
+  print "Refresh: 0; url=\"$ENV{SCRIPT_NAME}\"\n";
+  print "Content-Type: text/html\n\n<html> </html>\n";
+}
+
+# display the checkout form
+# can also be called with an error message and a flag to fillin the old
+# values for the form elements
+sub checkout {
+  my ($message, $olddata) = @_;
+
+  $message = '' unless defined $message;
+
+  update_quantities();
+  my @cart = @{$session{cart}};
+  my @cart_prods = map { Products->getByPkey($_->{productId}) } @cart;
+  my $item_index = -1;
+  my %acts;
+  %acts =
+    (
+     iterate_items => sub { ++$item_index < @cart },
+     item => 
+     sub { $cart[$item_index]{$_[0]} || $cart_prods[$item_index]{$_[0]} },
+     index => sub { $item_index },
+     total => sub { total(\@cart) },
+     money =>
+     sub {
+       my ($func, $args) = split ' ', $_[0], 2;
+       $acts{$func} || return "<: money $_[0] :>";
+       return sprintf("%.02f", $acts{$func}->($args)/100);
+     },
+     count => sub { scalar @cart },
+     message => sub { $message },
+     old => sub { $olddata ? param($_[0]) : '' },
+    );
+
+  page('checkout.tmpl', \%acts);
+}
+
+# the real work
+sub purchase {
+  # some basic validation, in case the user switched off javascript
+  my @required = 
+    qw(name1 name2 address city postcode state country cardHolder cardExpiry);
+  for my $field (@required) {
+    defined(param($field)) && length(param($field))
+      or return checkout("Field $field is required", 1);
+  }
+  defined(param('email')) && param('email') =~ /.\@./
+    or return checkout("Please enter a valid email address", 1);
+  defined(param('cardNumber')) && param('cardNumber') =~ /^\d+$/
+    or return checkout("Please enter a credit card number", 1);
+
+  use Orders;
+  use Order;
+  use OrderItems;
+  use OrderItem;
+
+  # map some form fields to order field names
+  my %field_map = 
+    (
+     name1 => 'delivFirstName',
+     name2 => 'delivLastName',
+     address => 'delivStreet',
+     city => 'delivSuburb',
+     postcode => 'delivPostCode',
+     state => 'delivState',
+     country => 'delivCountry',
+     email => 'emailAddress',
+     cardHolder => 'ccName',
+     cardType => 'ccType',
+    );
+  # paranoia, don't store these
+  my %nostore =
+    (
+     cardNumber => 1,
+     cardExpiry => 1,
+    );
+  my %order;
+  my @cart = @{$session{cart}};
+  @cart or return show_cart('You have no items in your shopping cart');
+
+  # so we can quickly check for columns
+  my @columns = Order->columns;
+  my %columns; 
+  @columns{@columns} = @columns;
+
+  for my $field (param()) {
+    $order{$field_map{$field} || $field} = param($field)
+      unless $nostore{$field};
+  }
+
+  my $ccNumber = param('cardNumber');
+  my $ccExpiry = param('cardExpiry');
+
+  use Digest::MD5 'md5_hex';
+  $ccNumber =~ tr/0-9//cd;
+  $order{ccNumberHash} = md5_hex($ccNumber);
+  $order{ccExpiryHash} = md5_hex($ccExpiry);
+
+  # work out totals
+  $order{total} = 0;
+  $order{gst} = 0;
+  $order{wholesale} = 0;
+  my @products;
+  my $today = epoch_to_sql(time);
+  for my $item (@cart) {
+    my $product = Products->getByPkey($item->{productId});
+    # double check that it's still a valid product
+    if (!$product) {
+      return show_cart("Product $item->{productId} not found");
+    }
+    elsif ($product->{release} gt $today || $product->{expire} lt $today
+          || !$product->{listed}) {
+      return show_cart("Sorry, '$product->{title}' is no longer available");
+    }
+    push(@products, $product); # used in page rendering
+    @$item{qw/price wholesalePrice gst/} = 
+      @$product{qw/retailPrice wholesalePrice gst/};
+    $order{total} += $item->{price} * $item->{units};
+    $order{wholesale} += $item->{wholesalePrice} * $item->{units};
+    $order{gst} += $item->{gst} * $item->{units};
+  }
+  $order{orderDate} = $today;
+
+  # blank anything else
+  for my $column (@columns) {
+    defined $order{$column} or $order{$column} = '';
+  }
+
+  # load up the database
+  my @data = @order{@columns};
+  shift @data; # lose the dummy id
+  my $order = Orders->add(@data)
+    or die "Cannot add order";
+  my @items;
+  my @item_cols = OrderItem->columns;
+  for my $row (@cart) {
+    $row->{orderId} = $order->{id};
+    my @data = @$row{@item_cols};
+    shift @data;
+    push(@items, OrderItems->add(@data));
+  }
+
+  my $item_index = -1;
+  my %acts;
+  %acts =
+    (
+     iterate_items_reset => sub { $item_index = -1; },
+     iterate_items => sub { ++$item_index < @items },
+     item=> sub { CGI::escapeHTML($items[$item_index]{$_[0]}); },
+     product => sub { CGI::escapeHTML($products[$item_index]{$_[0]}) },
+     order => sub { CGI::escapeHTML($order->{$_[0]}) },
+     money =>
+     sub {
+       my ($func, $args) = split ' ', $_[0], 2;
+       $acts{$func} || return "<: money $_[0] :>";
+       return sprintf("%.02f", $acts{$func}->($args)/100);
+     },
+     _format =>
+     sub {
+       my ($value, $fmt) = @_;
+       if ($fmt =~ /^m(\d+)/) {
+        return sprintf("%$1s", sprintf("%.2f", $value/100));
+       }
+       elsif ($fmt =~ /%/) {
+        return sprintf($fmt, $value);
+       }
+     },
+    );
+  send_order($order, \@items, \@products);
+  $session{cart} = []; # empty the cart
+  page('checkoutfinal.tmpl', \%acts);
+}
+
+# sends the email order confirmation and the PGP encrypted
+# email to the site owner
+sub send_order {
+  my ($order, $items, $products) = @_;
+
+  my %extras = %EXTRA_TAGS;
+  for my $key (keys %extras) {
+    unless (ref $extras{$key}) {
+      my $data = $extras{$key};
+      $extras{$key} = sub { $data };
+    }
+  }
+
+  my $item_index = -1;
+  my %acts;
+  %acts =
+    (
+     %extras,
+
+     iterate_items_reset => sub { $item_index = -1; },
+     iterate_items => sub { return ++$item_index < @$items },
+     item=> sub { $items->[$item_index]{$_[0]}; },
+     product => sub { $products->[$item_index]{$_[0]} },
+     order => sub { $order->{$_[0]} },
+     extended => 
+     sub {
+       $items->[$item_index]{units} * $items->[$item_index]{$_[0]};
+     },
+     money =>
+     sub {
+       my ($func, $args) = split ' ', $_[0], 2;
+       $acts{$func} || return "<: money $_[0] :>";
+       return sprintf("%.02f", $acts{$func}->($args)/100);
+     },
+     _format =>
+     sub {
+       my ($value, $fmt) = @_;
+       if ($fmt =~ /^m(\d+)/) {
+        return sprintf("%$1s", sprintf("%.2f", $value/100));
+       }
+       elsif ($fmt =~ /%/) {
+        return sprintf($fmt, $value);
+       }
+       elsif ($fmt =~ /^\d+$/) {
+        return substr($value . (" " x $fmt), 0, $fmt);
+       }
+       else {
+        return $value;
+       }
+     },
+    );
+  my $templ = Squirrel::Template->new;
+
+  # ok, send some email
+  my $confirm = $templ->show_page($TMPLDIR, 'mailconfirm.tmpl', \%acts);
+  if ($SHOP_EMAIL_ORDER) {
+    $acts{cardNumber} = sub { param('cardNumber') };
+    $acts{cardExpiry} = sub { param('cardExpiry') };
+    my $ordertext = $templ->show_page($TMPLDIR, 'mailorder.tmpl', \%acts);
+
+    eval "use $crypto_class";
+    !$@ or die $@;
+    my $encrypter = $crypto_class->new;
+
+    # encrypt and sign
+    my %opts = 
+      (
+       sign=> 1,
+       passphrase=> $passphrase,
+       stripwarn=>1,
+       #debug=>1,
+      );
+    $opts{secretkeyid} = $signing_id if $signing_id;
+    $opts{pgp} = $pgp if $pgp;
+    $opts{gpg} = $gpg if $gpg;
+    $opts{pgpe} = $pgpe if $pgpe;
+    #$opts{home} = '/home/bodyscoop';
+    my $recip = "$toName $toEmail";
+
+    my $crypted = $encrypter->encrypt($recip, $ordertext, %opts )
+      or die "Cannot encrypt ", $encrypter->error;
+
+    sendmail($toEmail, 'New Order', $crypted, $from);
+  }
+  sendmail($order->{emailAddress}, $subject . " " . localtime, $confirm, $from);
+
+}
+
+sub sendmail {
+  my ($recip, $subject, $body, $from) = @_;
+
+  open MAIL, "| $sendmail $opts"
+    or die "Cannot open pipe to sendmail: $!";
+  print MAIL <<EOS;
+From: $from
+To: $recip
+Subject: $subject
+
+$body
+EOS
+  close MAIL;
+}
+
+sub page {
+  my ($template, $acts) = @_;
+  print "Content-Type: text/html\n\n";
+  print Squirrel::Template->new->show_page($TMPLDIR, $template, $acts);
+}
+
+# convert an epoch time to sql format
+sub epoch_to_sql {
+  use POSIX 'strftime';
+  my ($time) = @_;
+
+  return strftime('%Y-%m-%d', localtime $time);
+}
+
+__END__
+
+=head1 NAME
+
+shop.pl - implements the shop for BSE
+
+=head1 DESCRIPTION
+
+shop.pl implements the shop for BSE.
+
+=head1 TAGS
+
+=head2 Cart page
+
+=over 4
+
+=item iterator ... items
+
+Iterates over the items in the shopping cart, setting the C<item> tag
+for each one.
+
+=item item I<field>
+
+Retreives the given field from the item.  This can include product
+fields for this item.
+
+=item index
+
+The numeric index of the current item.
+
+=item money I<which> <field>
+
+Formats the given field as a money value (without a currency symbol.)
+
+=item count
+
+The number of items in the cart.
+
+=back
+
+=head2 Checkout tags
+
+This has the same tags as the L<Cart page>, and some extras:
+
+=over 4
+
+=item total
+
+The total cost of all items in the cart.
+
+This will need to be formatted as a money value with the C<money> tag.
+
+=item message
+
+An error message, if a validation error occurred.
+
+=item old I<field>
+
+The previously entered value for I<field>.  This should be used as the
+value for the various checkout fields, so that if a validation error
+occurs the user won't need to re-enter values.
+
+=back
+
+=head2 Completed order
+
+These tags are used in the F<checkoutfinal_base.tmpl>.
+
+=over 4
+
+=item item I<field>
+
+=item product I<field>
+
+This is split out for these forms.
+
+=item order I<field>
+
+Order fields.
+
+=back
+
+You can also use "|format" at the end of a field to perform some
+simple formatting.  Eg. <:order total |m6:> or <:order id |%06d:>.
+
+=over 4
+
+=item m<number>
+
+Formats the value as a <number> wide money value.
+
+=item %<format>
+
+Performs sprintf() formatting on the value.  Eg. %06d will format 25
+as 000025.
+
+=back
+
+=head2 Mailed order tags
+
+These tags are used in the emails sent to the user to confirm an order
+and in the encrypted copy sent to the site administrator:
+
+=over 4
+
+=item iterate ... items
+
+Iterates over the items in the order.
+
+=item item I<field>
+
+Access to the given field in the order item.
+
+=item product I<field>
+
+Access to the product field for the current order item.
+
+=item order I<field>
+
+Access to fields of the order.
+
+=item extended I<field>
+
+The product of the I<field> in the current item and it's quantity.
+
+=item money I<tag> I<parameters>
+
+Formats the given field as a money value.
+
+=back
+
+The mail generation template can use extra formatting specified with
+'|format':
+
+=over 4
+
+=item m<number>
+
+Format the value as a I<number> wide money value.
+
+=item %<format>
+
+Performs sprintf formatting on the value.
+
+=item <number>
+
+Left justifies the value in a I<number> wide field.
+
+=back
+
+The order email sent to the site administrator has a couple of extra
+fields:
+
+=over 4
+
+=item cardNumber
+
+The credit card number of the user's credit card.
+
+=item cardExpiry
+
+The entered expiry date for the user's credit card.
+
+=back
+
+=head2 Order fields
+
+=over 4
+
+=item id
+
+The order id or order number.
+
+=item delivFirstName
+
+=item delivLastName
+
+=item delivStreet
+
+=item delivSuburb
+
+=item delivState
+
+=item delivPostCode
+
+=item delivCountry
+
+Delivery information for the order.
+
+=item billFirstName
+
+=item billLastName
+
+=item billStreet
+
+=item billSuburb
+
+=item billState
+
+=item billPostCode
+
+=item billCountry
+
+Billing information for the order.
+
+=item telephone
+
+=item facsimile
+
+=item emailAddress
+
+Contact information for the order.
+
+=item total
+
+Total price of the order.
+
+=item wholesaleTotal
+
+Wholesale cost of the total.  Your costs, if you entered wholesale
+prices for the products.
+
+=item gst
+
+GST (in Australia) payable on the order, if you entered GST for the products.
+
+=item orderDate
+
+When the order was made.
+
+=back
+
+=head2 Order item fields
+
+=over 4
+
+=item productId
+
+The product id of this item.
+
+=item orderId 
+
+The order Id.
+
+=item units
+
+The number of units for this item.
+
+=item price
+
+The price paid for the product.
+
+=item wholesalePrice
+
+The wholesale price for the product.
+
+=item gst
+
+The gst for the product.
+
+=back
+
+=cut
diff --git a/site/data/stopwords.txt b/site/data/stopwords.txt
new file mode 100644 (file)
index 0000000..796c9fc
--- /dev/null
@@ -0,0 +1,465 @@
+a
+about
+above
+according
+accordingly
+across
+actually
+adj
+after
+afterward
+afterwards
+again
+against
+albeit
+all
+almost
+alone
+along
+already
+also
+although
+always
+among
+amongst
+an
+and
+another
+any
+anyhow
+anyone
+anything
+anywhere
+are
+aren't
+around
+as
+at
+b
+be
+became
+because
+become
+becomes
+becoming
+been
+before
+beforehand
+began
+begin
+beginning
+behind
+being
+below
+beside
+besides
+between
+beyond
+billion
+bodyscoop
+both
+but
+by
+c
+can
+can't
+cannot
+caption
+certain
+co
+co.
+com
+could
+couldn't
+d
+did
+didn't
+do
+does
+doesn't
+don't
+down
+during
+e
+each
+eg
+eight
+eighty
+either
+else
+elsewhere
+end
+ending
+enough
+especially
+etc
+etc.
+even
+ever
+every
+everyone
+everything
+everywhere
+example
+except
+f
+few
+fewer
+fifty
+finally
+find
+first
+five
+following
+for
+former
+formerly
+forty
+found
+four
+from
+further
+furthermore
+g
+generally
+get
+given
+go
+going
+got
+h
+had
+has
+hasn't
+have
+haven't
+having
+he
+he'd
+he'll
+he's
+held
+hence
+henceforth
+her
+here
+here's
+hereafter
+hereby
+herein
+hereupon
+hers
+herself
+him
+himself
+his
+how
+however
+hundred
+i
+i'd
+i'll
+i'm
+i've
+ie
+if
+in
+inc
+inc.
+include
+included
+includes
+including
+indeed
+instead
+into
+is
+isn't
+it
+it's
+its
+itself
+iv
+j
+k
+knew
+know
+l
+last
+later
+latter
+latterly
+least
+less
+let
+let's
+like
+likely
+ltd
+m
+made
+make
+makes
+many
+may
+maybe
+me
+meantime
+meanwhile
+might
+million
+miss
+more
+moreover
+most
+mostly
+mr
+mrs
+much
+must
+my
+myself
+n
+namely
+near
+nearly
+neither
+never
+nevertheless
+next
+nine
+ninety
+no
+nobody
+none
+nonetheless
+noone
+nor
+not
+nothing
+now
+nowhere
+o
+of
+off
+often
+on
+once
+one
+one's
+only
+onto
+or
+other
+others
+otherwise
+our
+ours
+ourselves
+out
+over
+overall
+own
+p
+part
+particularly
+parts
+per
+perhaps
+probably
+q
+r
+rather
+re
+recent
+recently
+s
+same
+say
+see
+seem
+seemed
+seeming
+seemingly
+seems
+sent
+set
+seven
+seventy
+several
+she
+she'd
+she'll
+she's
+should
+shouldn't
+similar
+since
+six
+sixty
+so
+some
+somehow
+someone
+something
+sometime
+sometimes
+somewhat
+somewhere
+still
+stop
+such
+t
+taking
+ten
+than
+that
+that'll
+that's
+that've
+the
+their
+them
+themselves
+then
+thence
+thenceforth
+there
+there'd
+there'll
+there're
+there's
+there've
+thereafter
+thereby
+therefor
+therefore
+therein
+thereupon
+these
+they
+they'd
+they'll
+they're
+they've
+thirty
+this
+those
+though
+thousand
+three
+through
+throughout
+thru
+thus
+to
+together
+too
+took
+toward
+towards
+trillion
+twenty
+two
+u
+under
+unless
+unlike
+unlikely
+until
+up
+upon
+us
+use
+used
+using
+usually
+v
+various
+very
+vfor
+via
+w
+want
+was
+wasn't
+way
+we
+we'd
+we'll
+we're
+we've
+well
+were
+weren't
+what
+what'll
+what's
+what've
+whatever
+whatsoever
+when
+whence
+whenever
+whensoever
+where
+where's
+whereafter
+whereas
+whereat
+whereby
+wherefrom
+wherein
+whereinto
+whereof
+whereon
+whereto
+whereunto
+whereupon
+wherever
+wherewith
+whether
+which
+whichever
+whichsoever
+while
+whilst
+whither
+who
+who'd
+who'll
+who's
+whoever
+whole
+whom
+whomever
+whomsoever
+whose
+whosoever
+why
+will
+with
+within
+without
+won't
+would
+wouldn't
+x
+xauthor
+xcal
+xnote
+xother
+xsubj
+y
+yes
+yet
+you
+you'd
+you'll
+you're
+you've
+your
+yours
+yourself
+yourselves
+z
diff --git a/site/docs/bugs.pod b/site/docs/bugs.pod
new file mode 100755 (executable)
index 0000000..ae89aaa
--- /dev/null
@@ -0,0 +1,58 @@
+=head1 NAME
+
+bugs.pod - known problems in BSE
+
+=head1 DESCRIPTION
+
+=over 4
+
+=item *
+
+we don't have any regression tests.  This needs to be done.
+
+=item *
+
+Squirrel::Template needs to be a real parser.  Nested ifs can confuse
+the parsing a great deal.
+
+=item *
+
+Only the Squirrel::GPG module has seen use. The other two encryption
+modules probably don't work at all.
+
+=item *
+
+Bad namespace usage.  It would be better to have everything under
+Web::BSE (for example.)
+
+=item *
+
+The DatabaseHandle class is basically a global variable.  Ick.  This
+will cause us problems if we ever put this onto a mod_perl system.
+This is an issue for Constants.pm too.  Of course, since we generate
+most of the content to static files, mod_perl is probably a waste of
+time :).
+
+=item *
+
+Upgrading is hard.  Currently you need to manually copy a bunch of
+files, and modify Constants.pm.  If you re-extract then the files will
+potentially overwrite your templates, and your modified Constants.pm.
+Possibly this can be fixed by writing an installation tool, but this
+is moderately complex.
+
+=item *
+
+The directory in the tar file produced by the dist target always puts
+the files into the 'bse' directory.  This need to be changed to use
+the release number in the directory.  The dist file also contains some
+junk, a MANIFEST file will help here.
+
+=item *
+
+Too many url paths are global, which makes it very difficult to put
+two copies of BSE on the one site.
+
+=back
+
+=cut
diff --git a/site/docs/makedocs b/site/docs/makedocs
new file mode 100644 (file)
index 0000000..8f6aa99
--- /dev/null
@@ -0,0 +1,72 @@
+#!perl -w
+# Build HTML files from .pod and .pm files
+# I'd love to do this as a makefile, but the targets have colons, which
+# make hates (GNU make, anyway)
+use strict;
+
+my @targets =
+  (
+   'bse.html',
+   'bugs.html',
+   'templates.html',
+   'Generate.html',
+   'Generate::Article.html',
+   'Generate::Product.html',
+   'Generate::Catalog.html',
+   'search.html',
+   'shop.html',
+   'add.html',
+   'shopadmin.html',
+  );
+
+my @exts = qw(.pod .pm .pl);
+
+my @search =
+  (
+   '',
+   '../cgi-bin/',
+   '../cgi-bin/modules/',
+   '../cgi-bin/admin/',
+  );
+
+use Getopt::Std;
+my %opts;
+getopts("hn", \%opts);
+$opts{h} and usage();
+++$|;
+for my $target (@targets) {
+  # try to find the source
+  my $base = $target;
+  $base =~ s!::!/!g;
+  my $source;
+ SEARCH: for my $ext (@exts) {
+    (my $file = $base) =~ s/\.html$/$ext/;
+    for my $dir (@search) {
+      if (-e $dir.$file) {
+       $source = $dir.$file;
+       last SEARCH;
+      }
+    }
+  }
+  $source or die "Cannot find source for $target\n";
+  if (!-e $target || -M $target > -M $source) {
+    my $cmd = "pod2html --infile=$source --outfile=$target --htmlroot=.";
+    
+    print $cmd,"\n";
+    if (!$opts{n} and system $cmd) {
+       die "** makedocs failed\n";
+    }
+  }
+}
+
+# remove the pod2html caches - I don't care much if this fails
+unlink 'pod2html-dircache', 'pod2html-itemcache';
+
+sub usage {
+  print <<EOS;
+Usage: $0      - make the documentation files
+       $0 -n   - report what would be done to make the documentation files
+       $0 -h   - produce this message
+EOS
+  exit;
+}
diff --git a/site/htdocs/css/admin.css b/site/htdocs/css/admin.css
new file mode 100644 (file)
index 0000000..379944e
--- /dev/null
@@ -0,0 +1,17 @@
+a {  color: #333366; font-weight: bold}
+a:hover {  color: #6666CC}
+a:visited {  color: #333366}
+li {  font: 10px Verdana, Arial, Helvetica, sans-serif}
+h1 {  font-size: 18px; margin-left: -1.5em}
+h2 {  font-size: 12px; margin-left: -1em; padding-top: 1em}
+form {  display: inline}
+li {  padding-bottom: 10px;}
+td.sep {  background: #339; font-size: 0.1em}
+input.float { position: absolute; right: 1em}
+body {  font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 10px; margin-left: 4em; background-color: #FFFFFF}
+td {  font: 10px Verdana, Arial, Helvetica, sans-serif}
+p {  font: 10px Verdana, Arial, Helvetica, sans-serif}
+select {  font-family: "MS Sans Serif", Verdana, sans-serif; font-size: 12px}
+input {  font-family: "MS Sans Serif", Verdana, sans-serif; font-size: 12px}
+textarea {  font-family: "MS Sans Serif", Verdana, sans-serif; font-size: 12px}
+th {  font-size: 10px; font-weight: bold; background-color: #999999; color: #FFFFFF}
diff --git a/site/htdocs/css/style-main.css b/site/htdocs/css/style-main.css
new file mode 100644 (file)
index 0000000..64f973a
--- /dev/null
@@ -0,0 +1,42 @@
+.nav_link {  font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 9px; color: #333399}
+
+
+
+.nav_head {  font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 10pt; font-weight: bold; color: #333399}
+
+
+
+.article_body_text { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px; color: #000000}
+
+
+
+.article_body_heads { font-family: Arial, Helvetica, sans-serif; font-size: 14pt; font-weight: bold; color: #660033}
+
+
+
+.response_body_text { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px; color: #000000}
+
+
+
+.response_body_heads { font-family: Arial, Helvetica, sans-serif; font-size: 12pt; font-weight: bold; color: #660033}
+
+
+
+.index_heads { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 12pt; font-weight: bold; color: #660033}
+
+
+.section_Heading { font-family: Arial, Helvetica, sans-serif; font-size: 24pt; font-weight: bold; color: #333399}
+
+.section_body { font-family: Arial, Helvetica, sans-serif; font-size: 11pt; color: #000099; font-weight: bold}
+
+.subSection_Heading { font-family: Arial, Helvetica, sans-serif; font-size: 20pt; font-weight: bold; color: #333399}
+
+.subSection_body { font-family: Arial, Helvetica, sans-serif; font-size: 11pt; color: #333399; font-weight: bold}
+
+.index_body_text { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px; color: #000000 }
+
+.hot_heads { font-family: Arial, Helvetica, sans-serif; font-size: 14pt; font-weight: bold; color: #660033 }
+
+.hot_body_text { font-family: Verdana, Arial, Helvetica, sans-serif; font-size: 11px; color: #000000 }
+
+.join_button { border-color: #CCCCFF black black #CCCCFF; font-weight: bold; color: white; background-color: #333399; }
\ No newline at end of file