site/cgi-bin/admin/report.pl
site/cgi-bin/admin/shopadmin.pl
site/cgi-bin/admin/siteusers.pl
+#site/cgi-bin/admin/subadmin.pl
site/cgi-bin/admin/subs.pl
site/cgi-bin/admin/userlist.pl
site/cgi-bin/bse.cfg
site/cgi-bin/modules/BSE/TB/AdminPerms.pm
site/cgi-bin/modules/BSE/TB/AdminUser.pm
site/cgi-bin/modules/BSE/TB/AdminUsers.pm
+site/cgi-bin/modules/BSE/TB/Order.pm
+site/cgi-bin/modules/BSE/TB/Orders.pm
+site/cgi-bin/modules/BSE/TB/OrderItem.pm
+site/cgi-bin/modules/BSE/TB/OrderItems.pm
+#site/cgi-bin/modules/BSE/TB/Subscription.pm
+#site/cgi-bin/modules/BSE/TB/Subscriptions.pm
site/cgi-bin/modules/BSE/Template.pm
+#site/cgi-bin/modules/BSE/UI/AdminDispatch.pm
+#site/cgi-bin/modules/BSE/UI/Dispatch.pm
+#site/cgi-bin/modules/BSE/UI/SubAdmin.pm
site/cgi-bin/modules/BSE/UserReg.pm
site/cgi-bin/modules/BSE/Util/DynSort.pm
site/cgi-bin/modules/BSE/Util/Iterate.pm
site/cgi-bin/modules/DevHelp/Report.pm
site/cgi-bin/modules/DevHelp/Tags.pm
site/cgi-bin/modules/DevHelp/Tags/Iterate.pm
+site/cgi-bin/modules/DevHelp/Validate.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/Subscription.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/OtherParent.pm
site/cgi-bin/modules/OtherParents.pm
site/cgi-bin/modules/Product.pm
site/templates/admin/subs/send_error.tmpl
site/templates/admin/subs/send_form.tmpl
site/templates/admin/subs/start_send.tmpl
+#site/templates/admin/subscr/add.tmpl
+#site/templates/admin/subscr/edit.tmpl
+#site/templates/admin/subscr/list.tmpl
site/templates/admin/userlist.tmpl
site/templates/admin/users/add.tmpl
site/templates/admin/users/edit.tmpl
-VERSION=0.14_23
+VERSION=0.14_24
DISTNAME=bse-$(VERSION)
DISTBUILD=$(DISTNAME)
DISTTAR=../$(DISTNAME).tar
-- options that can be specified for this product
options varchar(255) not null,
+
+ subscription_id integer not null default -1,
+ subscription_period integer not null default 0,
+ subscription_usage integer not null default 3,
+ subscription_required integer not null default -1,
primary key(articleId)
);
billFacsimile varchar(80) not null default '',
billEmail varchar(255) not null default '',
+ siteuser_id integer,
+ affiliate_code varchar(40) not null default '',
+
+ shipping_cost integer not null default 0,
+
primary key (id),
index order_cchash(ccNumberHash),
index order_userId(userId, orderDate)
customStr2 varchar(255) null,
customStr3 varchar(255) null,
+ -- transferred from the product
+ title varchar(255) not null default '',
+ summary varchar(255) not null default '',
+ subscription_id integer not null default -1,
+ subscription_period integer not null default 0,
+
primary key (id),
index order_item_order(orderId, id)
);
primary key (id)
);
+-- these are mailing list subscriptions
drop table if exists subscription_types;
create table subscription_types (
id integer not null auto_increment,
perm_map varchar(255),
primary key (object_id, admin_id)
);
+
+-- -- these are "product" subscriptions
+-- drop table if exists bse_subscriptions;
+-- create table bse_subscriptions (
+-- subscription_id integer not null auto_increment primary key,
+
+-- text_id varchar(20) not null,
+
+-- title varchar(255) not null,
+
+-- description text not null,
+
+-- max_lapsed integer not null,
+
+-- unique (text_id)
+-- );
+
+-- drop table if exists bse_user_subscribed;
+-- create table bse_user_subscribed (
+-- subscription_id integer not null,
+-- siteuser_id integer not null,
+-- started_at date not null,
+-- ends_at date not null,
+-- primary key (subscription_id, siteuser_id)
+-- );
+
my $cfg = $req->cfg;
my $cgi = $req->cgi;
unless ($req->check_admin_logon()) {
- refresh_to_admin("/cgi-bin/admin/logon.pl");
+ refresh_to_admin($cfg, "/cgi-bin/admin/logon.pl");
exit;
}
my $parent = Articles->getByPkey($stepparent);
if ($parent) {
my @otherlinks = OtherParents->getBy(parentId=>$stepparent);
- my @normalkids = Articles->listedChildren($stepparent);
+ my @normalkids = Articles->children($stepparent);
my @stepkids = $parent->stepkids;
my %stepkids = map { $_->{id}, $_ } @stepkids;
@kids = (
=head1 SYNOPSIS
<html>...
- <a href="/cgi-bin/admin/reorder.pl?parentid=...&sort=...>Order</a>
+ <a href="/cgi-bin/admin/reorder.pl?parentid=...&sort=...>Order</a>
...</html>
=head1 DESCRIPTION
#use Carp; # 'verbose';
use Products;
use Product;
-use Orders;
-use Order;
-use OrderItems;
-use OrderItem;
+use BSE::TB::Orders;
+use BSE::TB::OrderItems;
use BSE::Template;
#use Squirrel::ImageEditor;
use Constants qw(:shop $SHOPID $PRODUCTPARENT
$req->user_can('shop_order_list')
or return product_list($req, "You don't have access to the order list");
- my $orders = Orders->new;
+ my $orders = BSE::TB::Orders->new;
my @orders = sort { $b->{orderDate} cmp $a->{orderDate} } $orders->all;
my $template = $req->cgi->param('template');
unless (defined $template && $template =~ /^\w+$/) {
$req->user_can('shop_order_list')
or return product_list($req, "You don't have access to the order list");
- my $orders = Orders->new;
+ my $orders = BSE::TB::Orders->new;
my @orders = sort { $b->{orderDate} cmp $a->{orderDate} }
grep $_->{filled} && $_->{paidFor}, $orders->all;
$req->user_can('shop_order_list')
or return product_list($req, "You don't have access to the order list");
- my $orders = Orders->new;
+ my $orders = BSE::TB::Orders->new;
my @orders = sort { $b->{orderDate} cmp $a->{orderDate} }
grep !$_->{filled} && $_->{paidFor}, $orders->all;
$req->user_can('shop_order_list')
or return product_list($req, "You don't have access to the order list");
- my $orders = Orders->new;
+ my $orders = BSE::TB::Orders->new;
my @orders = sort { $b->{orderDate} cmp $a->{orderDate} }
grep !$_->{paidFor}, $orders->all;
my $cgi = $req->cgi;
my $id = $cgi->param('id');
if ($id and
- my $order = Orders->getByPkey($id)) {
+ my $order = BSE::TB::Orders->getByPkey($id)) {
$message ||= $cgi->param('m') || '';
- my @lines = OrderItems->getBy('orderId', $id);
+ my @lines = $order->items;
my @products = map { Products->getByPkey($_->{productId}) } @lines;
my $line_index = -1;
my $product;
my $id = $req->cgi->param('id');
if ($id and
- my $order = Orders->getByPkey($id)) {
+ my $order = BSE::TB::Orders->getByPkey($id)) {
my $filled = $req->cgi->param('filled');
$order->{filled} = $filled;
if ($order->{filled}) {
--- /dev/null
+#!/usr/bin/perl -w
+# -d:ptkdb
+BEGIN { $ENV{DISPLAY} = '192.168.32.15:0.0' }
+use strict;
+use FindBin;
+use lib "$FindBin::Bin/../modules";
+use BSE::DB;
+use BSE::Request;
+use BSE::Template;
+use Carp 'confess';
+use BSE::UI::SubAdmin;
+
+$SIG{__DIE__} = sub { confess $@ };
+
+my $req = BSE::Request->new;
+my $result = BSE::UI::SubAdmin->dispatch($req);
+BSE::Template->output_result($req, $result);
--- /dev/null
+#!/usr/bin/perl -w
+# -d:ptkdb
+BEGIN { $ENV{DISPLAY} = '192.168.32.15:0.0' }
+use strict;
+use FindBin;
+use lib "$FindBin::Bin/../modules";
+use BSE::DB;
+use BSE::Request;
+use BSE::Template;
+use Carp 'confess';
+use BSE::UI::Affiliate;
+
+$SIG{__DIE__} = sub { confess $@ };
+
+my $req = BSE::Request->new;
+my $result = BSE::UI::Affiliate->dispatch($req);
+BSE::Template->output_result($req, $result);
searchIndexWC => 'select * from searchindex where id like ?',
Products=> 'select article.*, product.* from article, product where id = articleId',
- addProduct => 'insert product values(?,?,?,?,?,?,?)',
+ addProduct => 'insert product values(?,?,?,?,?,?,?,?,?,?,?)',
getProductByPkey => 'select article.*, product.* from article, product where id=? and articleId = id',
- replaceProduct => 'replace product values(?,?,?,?,?,?,?)',
+ replaceProduct => 'replace product values(?,?,?,?,?,?,?,?,?,?,?)',
'Products.stepProducts' => <<EOS,
select ar.*, pr.* from article ar, product pr, other_parents op
where ar.id = pr.articleId and op.childId = ar.id and op.parentId = ?
Orders => 'select * from orders',
getOrderByPkey => 'select * from orders where id = ?',
getOrderItemByOrderId => 'select * from order_item where orderId = ?',
- addOrder => 'insert orders values(null,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)',
- replaceOrder => 'replace orders values(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)',
- addOrderItem => 'insert order_item values(null,?,?,?,?,?,?,?,?,?,?,?,?,?)',
+ addOrder => 'insert orders values(null,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)',
+ replaceOrder => 'replace orders values(?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)',
+ addOrderItem => 'insert order_item values(null,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)',
getOrderByUserId => 'select * from orders where userId = ?',
getOrderItemByProductId => 'select * from order_item where productId = ?',
select distinct ap.*
from admin_perms ap, admin_groups ag
where ap.admin_id = ag.base_id and ag.name = 'everyone'
+SQL
+ Subscriptions => 'select * from bse_subscriptions',
+ addSubscription => 'insert bse_subscriptions values(null,?,?,?,?)',
+ replaceSubscription => 'replace bse_subscriptions values(?,?,?,?,?)',
+ deleteSubscription => <<SQL,
+delete from bse_subscriptions where subscription_id = ?
+SQL
+ getSubscriptionByPkey => <<SQL,
+select * from bse_subscriptions where subscription_id = ?
SQL
);
}
else {
my $value = $self->default_value($req, $article, $col);
+ defined $value or $value = '';
return escape_html($value);
}
}
my $link_titles = $self->{cfg}->entryBool('basic', 'link_titles', 0);
if ($link_titles) {
(my $extra = lc $article->{title}) =~ tr/a-z0-9/_/sc;
- $link .= "/".$extra;
+ $link .= "/" . $extra . ".html";
}
$link;
$self->validate_parent(\%data, $articles, $parent, \$msg)
or return $self->add_form($req, $articles, $msg);
- $self->fill_new_data($req, \%data, $articles);
my $level = $parent ? $parent->{level}+1 : 1;
+ $data{level} = $level;
$data{displayOrder} = time;
- $data{titleImage} ||= '';
- $data{imagePos} = 'tr';
- $data{release} = sql_date($data{release}) || now_sqldate();
- $data{expire} = sql_date($data{expire}) || $Constants::D_99;
- unless ($data{template}) {
- $data{template} ||=
- $self->{cfg}->entry("children of $data{parentid}", 'template');
- $data{template} ||=
- $self->{cfg}->entry("level $level", 'template');
- }
$data{link} ||= '';
$data{admin} ||= '';
- if ($parent) {
- $data{threshold} = $parent->{threshold}
- if !defined $data{threshold} || $data{threshold} =~ /^\s*$/;
- $data{summaryLength} = $parent->{summaryLength}
- if !defined $data{summaryLength} || $data{summaryLength} =~ /^\s*$/;
- }
- else {
- $data{threshold} = $self->{cfg}->entry("level $level", 'threshold', 5)
- if !defined $data{threshold} || $data{threshold} =~ /^\s*$/;
- $data{summaryLength} = 200
- if !defined $data{summaryLength} || $data{summaryLength} =~ /^\s*$/;
- }
$data{generator} = $self->generator;
$data{lastModified} = now_sqldatetime();
- $data{level} = $level;
$data{listed} = 1 unless defined $data{listed};
+ $self->fill_new_data($req, \%data, $articles);
+ for my $col (qw(titleImage imagePos template keyword)) {
+ defined $data{$col}
+ or $data{$col} = $self->default_value($req, \%data, $col);
+ }
+
+ # these columns are handled a little differently
+ for my $col (qw(release expire threshold summaryLength )) {
+ $data{$col}
+ or $data{$col} = $self->default_value($req, \%data, $col);
+ }
+
shift @columns;
my $article = $table_object->add(@data{@columns});
return $self->refresh($article, $req->cgi, undef, 'Article hidden');
}
+my %defaults =
+ (
+ titleImage => '',
+ imagePos => 'tr',
+ expire => $Constants::D_99,
+ listed => 1,
+ keyword => '',
+ );
+
sub default_value {
my ($self, $req, $article, $col) = @_;
my $section = "level $article->{level}";
my $value = $req->cfg->entry($section, $col);
defined($value) and return $value;
+
+ exists $defaults{$col} and return $defaults{$col};
+
+ $col eq 'release' and return now_sqldate();
+
+ if ($col eq 'threshold') {
+ my $parent = $article->{parentid} != -1
+ && Articles->getByPkey($article->{parentid});
+
+ $parent and return $parent->{threshold};
+
+ return 5;
+ }
- return '';
+ if ($col eq 'summaryLength') {
+ my $parent = $article->{parentid} != -1
+ && Articles->getByPkey($article->{parentid});
+
+ $parent and return $parent->{summaryLength};
+
+ return 200;
+ }
+
+ return;
}
sub flag_sections {
use Products;
use HTML::Entities;
use BSE::Template;
+use BSE::Util::Iterate;
my %money_fields =
(
return encode_entities($value);
}
+#sub iter_subs {
+# require BSE::TB::Subscriptions;
+# BSE::TB::Subscriptions->all;
+#}
+
sub low_edit_tags {
my ($self, $acts, $req, $article, $articles, $msg, $errors) = @_;
+ my $it = BSE::Util::Iterate->new;
return
(
product => [ \&hash_tag, $article ],
$self->SUPER::low_edit_tags($acts, $req, $article, $articles, $msg,
$errors),
alloptions => join(",", sort keys %Constants::SHOP_PRODUCT_OPTS),
+ #$it->make_iterator
+ #([ \&iter_subs, $req ], 'subscription', 'subscriptions'),
);
}
for my $col (keys %money_fields) {
my $value = $data->{$col};
+ defined $value or next;
unless ($value =~ /^\d+(\.\d{1,2})?\s*/) {
$errors->{$col} = "$money_fields{$col} invalid";
}
}
+
+ if (defined $data->{options}) {
+ my @bad_opts =grep !$Constants::SHOP_PRODUCT_OPTS{$_},
+ split /,/, $data->{options};
+ if (@bad_opts) {
+ $errors->{options} = "Bad product options '". join(",", @bad_opts)."' entered";
+ }
+ }
- my @bad_opts =grep !$Constants::SHOP_PRODUCT_OPTS{$_},
- split /,/, $data->{options};
- if (@bad_opts) {
- $errors->{options} = "Bad product options '". join(",", @bad_opts)."' entered";
+ my @subs;
+ for my $sub_field (qw(subscription_id subscription_required)) {
+ my $value = $data->{$sub_field};
+ defined $value or next;
+ if ($value ne '-1') {
+ #require BSE::TB::Subscriptions;
+ #@subs = BSE::TB::Subscriptions->all unless @subs;
+ #unless (grep $_->{subscription_id} == $value, @subs) {
+ $errors->{$sub_field} = "Invalid $sub_field value";
+ #}
+ }
+ }
+ if (defined $data->{subscription_period}) {
+ unless ($data->{subscription_period} =~ /^(?:|\d+)$/) {
+ $errors->{subscription_period} = "Invalid subscription period, it must be the number of months to subscribe";
+ }
+ }
+ if (defined $data->{subscription_usage}) {
+ unless ($data->{subscription_usage} =~ /^[123]$/) {
+ $errors->{subscription_usage} = "Invalid subscription usage";
+ }
}
return !keys %$errors;
}
}
}
- if (exists $src->{options}) {
- $data->{options} = $src->{options};
+ for my $field (qw(options subscription_id subscription_period
+ subscription_usage subscription_required)) {
+ if (exists $src->{$field}) {
+ $data->{$field} = $src->{$field};
+ }
+ elsif ($data == $src) {
+ # use the default
+ $data->{$field} = $self->default_value($req, $data, $field);
+ }
}
}
return ( 'product flags', $self->SUPER::flag_sections );
}
+my %defaults =
+ (
+ options => '',
+ subscription_id => -1,
+ subscription_required => -1,
+ subscription_period => 1,
+ subscription_usage => 3,
+ retailPrice => 0,
+ );
+
+sub default_value {
+ my ($self, $req, $article, $col) = @_;
+
+ my $value = $self->SUPER::default_value($req, $article, $col);
+ defined $value and return $value;
+
+ exists $defaults{$col} and return $defaults{$col};
+
+ return;
+}
+
1;
if ($article->{generator} eq 'Generate::Product') {
# can't delete products that have been used in orders
- require OrderItems;
- my @items = OrderItems->getBy(productId=>$article->{id});
+ require BSE::TB::OrderItems;
+ my @items = BSE::TB::OrderItems->getBy(productId=>$article->{id});
if (@items) {
return 1;
}
BSE::Template->output_result($req, $result);
}
+sub message {
+ my ($req, $errors) = @_;
+
+ my $msg = '';
+ if ($errors and keys %$errors) {
+ my @fields = $req->cgi->param;
+ my %work = %$errors;
+ my @lines;
+ for my $field (@fields) {
+ if (my $entry = delete $work{$field}) {
+ push @lines, ref($entry) ? grep $_, @$entry : $entry;
+ }
+ }
+ for my $entry (values %work) {
+ if (ref $entry) {
+ push @lines, grep $_, @$entry;
+ }
+ else {
+ push @lines, $entry;
+ }
+ }
+ my %seen;
+ @lines = grep !$seen{$_}++, @lines; # don't need duplicates
+ $msg = join "<br />", map escape_html($_), @lines;
+ }
+ if (!$msg && $req->cgi->param('m')) {
+ $msg = escape_html($req->cgi->param('m'));
+ }
+
+ return $msg;
+}
+
+sub dyn_response {
+ my ($req, $template, $acts) = @_;
+
+ my $base_template = $template;
+ my $t = $req->cgi->param('t');
+ if ($t && $t =~ /^\w+$/) {
+ $template .= "_$t";
+ }
+
+ return BSE::Template->get_response($template, $req->cfg, $acts,
+ $base_template);
+}
+
sub DESTROY {
my ($self) = @_;
if ($self->{session}) {
=item *
-userid -
+userid - id of the logged on normal user.
+
+=item *
+
+adminuserid - id of the logged on admin user.
+
+=item *
+
+affiliate_code - id of the affiliate set by affiliate.pl
=back
my $user = get_siteuser($session, $cfg, $cgi);
if (!$user && $reg_if_files) {
- require 'ArticleFiles.pm';
+ require ArticleFiles;
# scan to see if any of the products have files
+ # requires a subscription or subscribes
for my $prod (@$cart_prods) {
my @files = ArticleFiles->getBy(articleId=>$prod->{id});
if (grep $_->{forSale}, @files) {
return ("register before checkout", "shop/fileitems");
}
+ if ($prod->{subscription_id} != -1) {
+ return ("you must be logged in to purchase a subscription", "shop/buysub");
+ }
+ if ($prod->{subscription_required} != -1) {
+ return ("must be logged in to purchse a product requiring a subscription", "shop/subrequired");
+ }
}
}
if (!$user && $require_logon) {
return ("register before checkout", "shop/logonrequired");
}
+
+ # check the user has the right required subs
+ # and that they qualify to subscribe for limited subscription products
+ if ($user) {
+ for my $prod (@$cart_prods) {
+ my $sub = $prod->subscription_required;
+ unless ($user->is_subscribed($sub)) {
+ return ("you must be subscribed to $sub->{title} to purchase one of these products", "shop/subrequired");
+ }
+
+ $sub = $prod->subscription;
+ if ($sub->renew_only) {
+ unless ($user->is_subscribed_grace) {
+ return ("you must be subscribed to $sub->{title} to use this renew only product", "sub/renewsubonly");
+ }
+ }
+ if ($sub->new_only) {
+ if ($user->is_subscribed_grace) {
+ return ("you must not be subscribed to $sub->{title} already to use this new subscription only product", "sub/newsubonly");
+ }
+ }
+ }
+ }
return;
}
$types{$type}{enabled} = 1;
}
- use Data::Dumper;
- print STDERR Dumper \%types;
+ #use Data::Dumper;
+ #print STDERR Dumper \%types;
return values %types;
}
--- /dev/null
+package BSE::TB::Order;
+use strict;
+# 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
+ filled whenFilled whoFilled paidFor paymentReceipt
+ randomId cancelled userId paymentType
+ customInt1 customInt2 customInt3 customInt4 customInt5
+ customStr1 customStr2 customStr3 customStr4 customStr5
+ instructions billTelephone billFacsimile billEmail
+ siteuser_id affiliate_code shipping_cost/;
+}
+
+=item siteuser
+
+returns the SiteUser object of the user who made this order.
+
+=cut
+
+sub siteuser {
+ my ($self) = @_;
+
+ $self->{userId} or return;
+
+ require SiteUsers;
+
+ return ( SiteUsers->getBy(userId=>$self->{userId}) )[0];
+}
+
+sub items {
+ my ($self) = @_;
+
+ require BSE::TB::OrderItems;
+ return BSE::TB::OrderItems->getBy(orderId => $self->{id});
+}
+
+1;
--- /dev/null
+package BSE::TB::OrderItem;
+use strict;
+# 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 options
+ customInt1 customInt2 customInt3 customStr1 customStr2 customStr3
+ title summary subscription_id subscription_period/;
+}
+
+1;
--- /dev/null
+package BSE::TB::OrderItems;
+use strict;
+use Squirrel::Table;
+use vars qw(@ISA $VERSION);
+@ISA = qw(Squirrel::Table);
+use BSE::TB::OrderItem;
+
+sub rowClass {
+ return 'BSE::TB::OrderItem';
+}
+
+1;
--- /dev/null
+package BSE::TB::Orders;
+use strict;
+use Squirrel::Table;
+use vars qw(@ISA $VERSION);
+@ISA = qw(Squirrel::Table);
+use BSE::TB::Order;
+
+sub rowClass {
+ return 'BSE::TB::Order';
+}
+
+1;
--- /dev/null
+package BSE::TB::Subscription;
+use strict;
+use Squirrel::Row;
+use vars qw/@ISA/;
+@ISA = qw/Squirrel::Row/;
+
+sub columns {
+ return qw/subscription_id text_id title description max_lapsed/;
+}
+
+sub primary { 'subscription_id' }
+
+# call as a method for edits
+sub valid_rules {
+ my ($self, $cfg) = @_;
+
+ my @subs = BSE::TB::Subscriptions->all;
+ if (ref $self) {
+ @subs = grep $_->{subscription_id} != $self->{subscription_id}, @subs;
+ }
+ my $notsubid_match = join '|', map $_->{text_id}, @subs;
+
+ return
+ (
+ identifier => { match => qr/^\w+$/,
+ error => '$n must contain only letters and digits, and no spaces' },
+ notsubid => { nomatch => qr/^(?:$notsubid_match)$/,
+ error => 'Duplicate identifier' },
+ );
+}
+
+sub valid_fields {
+ return
+ (
+ text_id => { description=>"Identifier",
+ rules=>'required;identifier;notsubid' },
+ title => { description=>"Title",
+ required => 1 },
+ description => { description=>"Description" },
+ max_lapsed => { description => 'Max lapsed',
+ rules => 'required;natural', },
+ );
+}
+
+1;
--- /dev/null
+package BSE::TB::Subscriptions;
+use strict;
+use Squirrel::Table;
+use vars qw(@ISA $VERSION);
+@ISA = qw(Squirrel::Table);
+use BSE::TB::Subscription;
+
+sub rowClass {
+ return 'BSE::TB::Subscription';
+}
+
+1;
sub get_refresh {
my ($class, $url, $cfg) = @_;
+ # the commented out headers were meant to help Opera, but they didn't
return
{
type=>$class->html_type($cfg),
content=>"<html></html>",
- headers=>[ qq/Refresh: 0; url=$url/ ],
+ headers=>[ qq/Refresh: 0; url=$url/,
+ #qq/Cache-Control: no-store, no-cache, must-revalidate, post-check=0, pre-check=0, max-age=0/,
+ #qq/Pragma: no-cache/,
+ #qq/Expires: Thu, 01 Jan 1970 00:00:00 GMT/
+ ],
};
}
--- /dev/null
+package BSE::UI::AdminDispatch;
+use strict;
+use base qw(BSE::UI::Dispatch);
+use BSE::CfgInfo qw(admin_base_url);
+use Carp qw(confess);
+
+# checks we're coming from HTTPS
+sub check_secure {
+ my ($class, $req, $rresult) = @_;
+
+ my $securl = admin_base_url($req->cfg);
+ my ($protocol, $host) = $securl =~ m!^(\w+)://([-\w.]+)!
+ or confess "Invalid [site].secureurl\n";
+
+ $host = lc $host;
+
+ my $curr_host = lc $ENV{SERVER_NAME};
+ my $curr_https = exists $ENV{HTTPS} || exists $ENV{SSL_CIPHER};
+ my $curr_proto = $curr_https ? 'https' : 'http';
+
+ return 1 if $curr_host eq $host && $curr_proto eq $protocol;
+
+ print STDERR "User is coming to use via a non-secure URL\n";
+ print STDERR "curr host >$curr_host< secure_host >$host<\n";
+ print STDERR "curr proto >$curr_proto< secure_proto >$protocol<\n";
+
+ # refresh back to the secure URL
+ my $target = ($ENV{SCRIPT_NAME} =~ /(\w+)\.pl$/)[0] or die;
+ my $url = $req->url($target => { $class->default_action => 1 });
+ $$rresult = BSE::Template->get_refresh($url, $req->cfg);
+
+ return;
+}
+
+sub check_action {
+ my ($class, $req, $action, $rresult) = @_;
+
+ # this is admin, the user must be logged on
+ unless ($req->check_admin_logon) {
+ # time to logon
+ # if this was a GET, try to refresh back to it after logon
+ my %extras =
+ (
+ 'm' => 'You must logon to use this function'
+ );
+ if ($ENV{REQUEST_METHOD} eq 'GET') {
+ my $rurl = admin_base_url($req->cfg) . $ENV{SCRIPT_NAME};
+ $rurl .= "?" . $ENV{QUERY_STRING} if $ENV{QUERY_STRING};
+ $rurl .= $rurl =~ /\?/ ? '&' : '?';
+ $rurl .= "refreshed=1";
+ $extras{r} = $rurl;
+ }
+ my $url = $req->url(logon => \%extras);
+ $$rresult = BSE::Template->get_refresh($url, $req->cfg);
+ return;
+ }
+
+ my $security = $class->rights;
+
+ return 1 unless $security->{$action};
+
+ my $msg;
+ my $rights = $security->{$action};
+ ref $rights or $rights = [ split /,/, $rights ];
+ for my $right (@$rights) {
+ unless ($req->user_can($right, -1, \$msg)) {
+ my $url = $req->url(menu =>
+ { 'm' => 'You do not have access to this function '.$msg });
+ $$rresult = BSE::Template->get_refresh($url, $req->cfg);
+ return;
+ }
+ }
+
+ return 1;
+}
+
+1;
--- /dev/null
+package BSE::UI::Affiliate;
+use strict;
+
+use base qw(BSE::UI::Dispatch);
+
+my %actions =
+ (
+ setaff => 1,
+ show => 1,
+ none => 1,
+ );
+
+sub actions { \%actions }
+
+sub default_action { 'none' }
+
+sub req_setaff {
+ my ($class, $req) = @_;
+
+ my $cgi = $req->cgi;
+ my $cgi = $req->cfg;
+ my $id = $cgi->param('id');
+
+ defined($id) && $id =~ /^\w+$/
+ or return $class->req_none($req, "Missing or invalid id");
+
+ my $allowed_referer = $cfg->entry('affiliate', 'allowed_referer');
+ my $require_referer = $cfg->entry('affiliate', 'require_referer');
+ if ($allowed_referer) {
+ my @allowed = split /;/, $allowed_referer;
+ my $referer = $ENV{HTTP_REFERER};
+ if ($referer) {
+ my ($domain) = ($referer =~ m!^\w+://([\w/]+)!);
+ $domain = lc $domain;
+ my $found = 0;
+ for my $entry (@allowed) {
+ $entry = lc $entry;
+
+ if ($length($entry) < $domain &&
+ $entry eq substr($domain, -length($entry))) {
+ ++$found;
+ last;
+ }
+ }
+ $found
+ or return $class->req_none($req, "$domain not in the permitted list of referers");
+ }
+ else {
+ $require_referer
+ and return $class->req_none($req, 'Referer not supplied');
+ }
+ }
+
+ my $url = $cgi->param('r');
+ $url ||= $cgi->entry('affiliate', 'default_refresh');
+ $url ||= $cgi->entryVar('site', 'url');
+
+ $req->session->{affiliate_code} = $id;
+
+ return BSE::Template->get_refresh($url, $cfg);
+}
+
+# display the affiliate page for a given user
+# this doesn't set the affiliate code (should it?)
+sub req_show {
+ my ($class, $req) = @_;
+
+ my $cgi = $req->cgi;
+ my $cfg = $req->cfg;
+
+ my $id = $cgi->param('id');
+ defined $id
+ or return $class->req_none($req, "No identifier supplied");
+ require SiteUsers;
+ require BSE::TB::Subscriptions;
+ my $user = SiteUsers->getBy(userId => $id);
+ $user
+ or return $class->req_none($req, "Unknown user");
+ my $subid = $cfg->entry('affiliate', 'subscription_required');
+ if ($subid) {
+ my $sub = BSE::TB::Subscriptions->getByPkey($subid)
+ || BSE::TB::Subscriptions->getBy(text_id => $subid)
+ or return $class->req_none($req, "Configuration error: Unknown subscription id");
+
+
+ }
+}
+
+1;
--- /dev/null
+package BSE::UI::Dispatch;
+use strict;
+use Carp 'confess';
+
+sub dispatch {
+ my ($class, $req) = @_;
+
+ my $result;
+ $class->check_secure($req, \$result)
+ or return $result;
+
+ my $actions = $class->actions;
+
+ my $cgi = $req->cgi;
+ my $action;
+ for my $check (keys %$actions) {
+ if ($cgi->param("a_$check")) {
+ $action = $check;
+ last;
+ }
+ }
+ $action ||= $class->default_action;
+
+ $class->check_action($req, $action, \$result)
+ or return $result;
+
+ my $method = "req_$action";
+ $class->$method($req);
+}
+
+sub check_secure {
+ my ($class, $req, $rresult) = @_;
+
+ return 1;
+}
+
+sub check_action {
+ my ($class, $req, $action, $rresult) = @_;
+
+ return 1;
+}
+
+1;
--- /dev/null
+package BSE::UI::SubAdmin;
+use strict;
+use base qw(BSE::UI::AdminDispatch);
+use BSE::Util::Tags qw(tag_hash tag_error_img);
+use BSE::Util::DynSort qw(sorter tag_sorthelp);
+use DevHelp::Validate qw(dh_validate);
+use BSE::Template;
+use BSE::Util::Iterate;
+use BSE::TB::Subscriptions;
+use DevHelp::HTML;
+
+my %rights =
+ (
+ list => 'bse_subs_list',
+ addform => 'bse_subs_add',
+ add => 'bse_subs_add',
+ edit => 'bse_subs_edit',
+ save => 'bse_subs_edit',
+ detail => 'bse_subs_detail',
+ );
+
+sub actions { \%rights }
+
+sub rights { \%rights }
+
+sub default_action { 'list' }
+
+sub req_list {
+ my ($class, $req, $errors) = @_;
+
+ my $msg = $req->message($errors);
+ my $cgi = $req->cgi;
+ my @subs = BSE::TB::Subscriptions->all;
+ my ($sortby, $reverse) =
+ sorter(data=>\@subs, cgi=>$cgi, sortby=>'subscription_id',
+ session=>$req->session,
+ name=>'subs', fields=> { subscription_id => {numeric => 1 },
+ max_lapsed => { numeric => 1}});
+ my $it = BSE::Util::Iterate->new;
+
+ my %acts;
+ %acts =
+ (
+ BSE::Util::Tags->basic(\%acts, $req->cgi, $req->cfg),
+ BSE::Util::Tags->admin(\%acts, $req->cfg),
+ BSE::Util::Tags->secure($req),
+ msg => $msg,
+ message => $msg,
+ $it->make_paged_iterator('isubscription', 'subscriptions', \@subs, undef,
+ $cgi, undef, 'pp=20', $req->session,
+ 'subscriptions'),
+ sorthelp => [ \&tag_sorthelp, $sortby, $reverse ],
+ sortby=>$sortby,
+ reverse=>$reverse,
+ );
+
+ return $req->dyn_response('admin/subscr/list', \%acts);
+}
+
+sub req_addform {
+ my ($class, $req, $errors) = @_;
+
+ my $msg = $req->message($errors);
+
+ my %acts;
+ %acts =
+ (
+ BSE::Util::Tags->basic(\%acts, $req->cgi, $req->cfg),
+ BSE::Util::Tags->admin(\%acts, $req->cfg),
+ BSE::Util::Tags->secure($req),
+ msg => $msg,
+ message => $msg,
+ error_img => [ \&tag_error_img, $req->cfg, $errors ],
+ );
+
+ return $req->dyn_response('admin/subscr/add', \%acts);
+}
+
+sub req_add {
+ my ($class, $req) = @_;
+
+ my $cgi = $req->cgi;
+ my $cfg = $req->cfg;
+ my %fields = BSE::TB::Subscription->valid_fields($cfg);
+ my %rules = BSE::TB::Subscription->valid_rules($cfg);
+ my %errors;
+ dh_validate($cgi, \%errors,
+ { fields => \%fields, rules=> \%rules },
+ $cfg, "BSE Subscription Validation");
+
+ keys %errors
+ and return $class->req_addform($req, \%errors);
+
+ my %sub;
+ for my $field (keys %fields) {
+ $sub{$field} = $cgi->param($field);
+ }
+ my @cols = BSE::TB::Subscription->columns;
+ shift @cols;
+ my $sub = BSE::TB::Subscriptions->add(@sub{@cols});
+
+ my $r = $class->_list_refresh($req, "Subscription $sub{text_id} added");
+
+ return BSE::Template->get_refresh($r, $req->cfg);
+}
+
+sub req_edit {
+ my ($class, $req, $errors) = @_;
+
+ my $sub_id = $req->cgi->param('subscription_id');
+ $sub_id && $sub_id =~ /^\d+/
+ or return $class->req_list
+ ($req, { subscription_id=>'Missing or invalid subscription_id' });
+ my $sub = BSE::TB::Subscriptions->getByPkey($sub_id);
+ $sub
+ or return $class->req_list
+ ($req, { subscription_id=>'Unknown subscription_id' });
+
+ my $msg = $req->message($errors);
+
+ my %acts;
+ %acts =
+ (
+ BSE::Util::Tags->basic(\%acts, $req->cgi, $req->cfg),
+ BSE::Util::Tags->admin(\%acts, $req->cfg),
+ BSE::Util::Tags->secure($req),
+ msg => $msg,
+ message => $msg,
+ error_img => [ \&tag_error_img, $req->cfg, $errors ],
+ subscription => [ \&tag_hash, $sub ],
+ );
+
+ return $req->dyn_response('admin/subscr/edit', \%acts);
+}
+
+sub req_save {
+ my ($class, $req) = @_;
+
+ my $sub_id = $req->cgi->param('subscription_id');
+ $sub_id && $sub_id =~ /^\d+/
+ or return $class->req_list
+ ($req, { subscription_id=>'Missing or invalid subscription_id' });
+ my $sub = BSE::TB::Subscriptions->getByPkey($sub_id);
+ $sub
+ or return $class->req_list
+ ($req, { subscription_id=>'Unknown subscription_id' });
+
+ my $cgi = $req->cgi;
+ my $cfg = $req->cfg;
+ my %fields = $sub->valid_fields($cfg);
+ my %rules = $sub->valid_rules($cfg);
+ my %errors;
+ dh_validate($cgi, \%errors,
+ { fields => \%fields, rules=> \%rules },
+ $cfg, "BSE Subscription Validation");
+
+ keys %errors
+ and return $class->req_edit($req, \%errors);
+
+ for my $field (keys %fields) {
+ $sub->{$field} = $cgi->param($field);
+ }
+
+ $sub->save;
+
+ my $r = $class->_list_refresh($req, "Subscription $sub->{text_id} saved");
+
+ return BSE::Template->get_refresh($r, $req->cfg);
+}
+
+sub req_detail {
+ my ($class, $req) = @_;
+
+ my $sub_id = $req->cgi->param('subscription_id');
+ $sub_id && $sub_id =~ /^\d+/
+ or return $class->req_list
+ ($req, { subscription_id=>'Missing or invalid subscription_id' });
+ my $sub = BSE::TB::Subscriptions->getByPkey($sub_id);
+ $sub
+ or return $class->req_list
+ ($req, { subscription_id=>'Unknown subscription_id' });
+
+ my $msg = $req->message($errors);
+
+ my %acts;
+ %acts =
+ (
+ BSE::Util::Tags->basic(\%acts, $req->cgi, $req->cfg),
+ BSE::Util::Tags->admin(\%acts, $req->cfg),
+ BSE::Util::Tags->secure($req),
+ msg => $msg,
+ message => $msg,
+ subscription => [ \&tag_hash, $sub ],
+ # products that use it
+ # users subscribed to it
+ );
+
+ return $req->dyn_response('admin/subscr/detail', \%acts);
+}
+
+sub _list_refresh {
+ my ($class, $req, $msg) = @_;
+
+ my $r = $req->cgi->param('r') || $req->cgi->param('refreshto');
+ unless ($r) {
+ $r = "/cgi-bin/admin/subadmin.pl";
+ }
+ if ($msg) {
+ my $sep = $r =~ /\?/ ? '&' : '?';
+
+ $r .= $sep . escape_uri($msg);
+ }
+
+ return $r;
+}
+
+1;
# whew, so we should have an article
$req->user_can($perm, $article)
- or return;
+ or return 0;
}
return 1;
defined or $_ = '' for @out;
my $tmp = $with;
{
- $tmp =~ s/\$([1-9\$])/$1 eq '$' ? '$' :
+ $tmp =~ s/\$([1-9\$])/
$1 eq '$' ? '$' : $out[$1-1] /ge;
}
$tmp;
defined or $_ = '' for @out;
my $tmp = $with;
{
- $tmp =~ s/\$([1-9\$])/$1 eq '$' ? '$' :
+ $tmp =~ s/\$([1-9\$])/
$1 eq '$' ? '$' : $out[$1-1] /ge;
}
$tmp;
--- /dev/null
+package DevHelp::Validate;
+use strict;
+require Exporter;
+use vars qw(@EXPORT_OK @ISA);
+@EXPORT_OK = qw(dh_validate dh_validate_hash dh_fieldnames);
+@ISA = qw(Exporter);
+
+sub new {
+ my ($class, %opts) = @_;
+
+ return bless \%opts, $class;
+}
+
+my %built_ins =
+ (
+ email =>
+ {
+ match => qr/^[^\@]+\@[\w.-]+\.\w+$/,
+ error => '$n is not a valid email address',
+ },
+ phone =>
+ {
+ match => qr/\d(?:\D*\d){3}/,
+ error => '$n is not a valid phone number',
+ },
+ postcode =>
+ {
+ match => qr/\d(?:\D*\d){3}/,
+ error => '$n is not a valid post code',
+ },
+ url =>
+ {
+ match => qr!^\w+://[\w-]+(?:\.[\w-]+)+(?::\d+)?!,
+ error => '$n is not a valid URL',
+ },
+ weburl =>
+ {
+ match => qr!^https?://[\w-]+(?:\.[\w-]+)+(?::\d+)?!,
+ error => '$n is not a valid URL, it must start with http:// or https://',
+ },
+ newbieweburl =>
+ {
+ match => qr!^(?:https?://)?[\w-]+(?:\.[\w-]+)+(?::\d+)?!,
+ error => '$n is not a valid URL',
+ },
+ confirm =>
+ {
+ confirm=>'password',
+ },
+ newconfirm =>
+ {
+ newconfirm=>'password',
+ },
+ required =>
+ {
+ required => 1,
+ },
+ abn =>
+ {
+ match => qr/\d(?:\D*\d){7}/,
+ error => '$n is not a valid ABN',
+ },
+ creditcardnumber =>
+ {
+ match => qr/^\D*\d(?:\D*\d){11,15}\D*$/,
+ error => '$n is not a valid credit card number',
+ },
+ creditcardexpiry =>
+ {
+ ccexpiry => 1,
+ },
+ miaa =>
+ {
+ match => qr/^\s*\d{1,6}\s*$/,
+ error => 'Not a valid MIAA membership number',
+ },
+ decimal =>
+ {
+ match => qr/^\s*(?:\d+(?:\.\d*)?|\.\d+)\s*$/,
+ error => 'Not a valid number',
+ },
+ money =>
+ {
+ match => qr/^\s*(?:\d+(?:\.\d\d)?|\.\d\d)\s*$/,
+ error => 'Not a valid money amount',
+ },
+ date =>
+ {
+ date => 1,
+ },
+ birthdate =>
+ {
+ date => 1,
+ maxdate => '+0y',
+ maxdatemsg => 'Your $n must be in the past',
+ },
+ adultbirthdate =>
+ {
+ date => 1,
+ maxdate => '-10y',
+ maxdatemsg => 'You must be at least 10 years old...',
+ mindate => '-100y',
+ },
+ futuredate =>
+ {
+ date => 1,
+ mindate => '-1d',
+ mindatemsg => 'The date entered must be in the future',
+ },
+ natural =>
+ {
+ integer => '0-', # 0 or higher
+ },
+ positiveint =>
+ {
+ integer => '1-', # 1 or higher
+ },
+ );
+
+sub dh_validate {
+ my ($cgi, $errors, $validation, $cfg, $section) = @_;
+
+ return DevHelp::Validate::CGI->new(cfg=>$cfg, cgi=>$cgi, section=>$section)
+ ->validate($errors, $validation);
+}
+
+sub dh_validate_hash {
+ my ($hash, $errors, $validation, $cfg, $section) = @_;
+
+ return DevHelp::Validate::Hash->new(cfg=>$cfg, hash=>$hash, section=>$section)
+ ->validate($errors, $validation);
+}
+
+sub validate {
+ my ($self, $errors, $validation) = @_;
+
+ my $rules = $validation->{rules};
+ my $fields = $validation->{fields};
+ my $optional = $validation->{optional};
+
+ my %cfg_rules;
+ _get_cfg_fields(\%cfg_rules, $self->{cfg}, $self->{section}, $fields)
+ if $self->{cfg} && $self->{section};
+
+ for my $rulename (keys %$rules) {
+ unless (exists $cfg_rules{rules}{$rulename}) {
+ $cfg_rules{rules}{$rulename} = $rules->{$rulename};
+ }
+ }
+ for my $rulename (keys %built_ins) {
+ unless (exists $cfg_rules{rules}{$rulename}) {
+ $cfg_rules{rules}{$rulename} = $built_ins{$rulename};
+ }
+ }
+
+ # merge the supplied fields into the config fields
+ my $cfg_fields = $cfg_rules{fields};
+ for my $field ( keys %$fields ) {
+ my $src = $fields->{$field};
+
+ my $dest = $cfg_fields->{$field} || {};
+
+ # the config overrides the software supplied fields
+ for my $override (qw(description required required_error)) {
+ if (defined $src->{$override} && !defined $dest->{$override}) {
+ $dest->{$override} = $src->{$override};
+ }
+ }
+
+ # but we add rules
+ if ($dest->{rules}) {
+ my $rules = $src->{rules};
+
+ # make a copy of the rules array if it's supplied that way so
+ # we don't modify someone else's data
+ $rules = ref $rules ? [ @$rules ] : [ split /;/, $rules ];
+
+ push @$rules, split /;/, $dest->{rules};
+ }
+ elsif ($src->{rules}) {
+ $dest->{rules} = $src->{rules};
+ }
+
+ $cfg_fields->{$field} = $dest if keys %$dest;
+ }
+ for my $field ( keys %$cfg_fields ) {
+ $self->validate_field($field, $cfg_fields->{$field}, $cfg_rules{rules},
+ $optional, $errors);
+ }
+
+ !keys %$errors;
+}
+
+sub validate_field {
+ my ($self, $field, $info, $rules, $optional, $errors) = @_;
+
+ my @data = $self->param($field);
+
+ my $required = $info->{required};
+ if (@data && $data[0] !~ /\S/ && $info->{required_if}) {
+ # field is required if any of the named fields are non-blank
+ for my $testfield (split /;/, $info->{required_if}) {
+ my $testvalue = $self->param($testfield);
+ if (defined $testvalue && $testvalue =~ /\S/) {
+ ++$required;
+ last;
+ }
+ }
+ }
+
+ my $rule_names = $info->{rules};
+ defined $rule_names or $rule_names = '';
+ $rule_names = [ split /;/, $rule_names ] unless ref $rule_names;
+
+ push @$rule_names, 'required' if $required;
+
+ @$rule_names or return;
+
+ RULE: for my $rule_name (@$rule_names) {
+ my $rule = $rules->{$rule_name};
+ unless ($rule) {
+ $rule = $self->_get_cfg_rule($rule_name);
+ if ($rule) {
+ $rules->{$rule_name} = $rule;
+ }
+ else {
+ print STDERR "** Unknown validation rule $rule_name for $field\n";
+ }
+ }
+ if (!$optional && $rule->{required} && !@data ) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ $info->{required_error} ||
+ $rule->{required_error} ||
+ '$n is a required field');
+ last RULE;
+ }
+ for my $data (@data) {
+ if ($rule->{required} && $data !~ /\S/) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ $info->{required_error} ||
+ $rule->{required_error} ||
+ '$n is a required field');
+ last RULE;
+ }
+ if ($rule->{newconfirm}) {
+ my $other = $self->param($rule->{newconfirm});
+ if ($other ne '' || $data ne '') {
+ if ($other ne $data) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ q!$n doesn't match the password!);
+ last RULE;
+ }
+ }
+ }
+ if ($data !~ /\S/ && !$rule->{required}) {
+ next RULE;
+ }
+ if ($rule->{match}) {
+ my $match = $rule->{match};
+ unless ($data =~ /$match/) {
+ $errors->{$field} = _make_error($field, $info, $rule);
+ last RULE;
+ }
+ }
+ if ($rule->{nomatch}) {
+ my $match = $rule->{nomatch};
+ if ($data =~ /$match/) {
+ $errors->{$field} = _make_error($field, $info, $rule);
+ last RULE;
+ }
+ }
+ if ($rule->{integer}) {
+ unless ($data =~ /^\s*([-+]?\d+)s*$/) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ '$n must be a whole number');
+ last RULE;
+ }
+ my $num = $1;
+ if (my ($from, $to) = $rule->{integer} =~ /^([+-]?\d+)-([+-]?\d+)$/) {
+ unless ($from <= $num and $num <= $to) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ $info->{range_error} ||
+ $rule->{range_error} ||
+ "\$n must be in the range $from to $to");
+ last RULE;
+ }
+ }
+ elsif (my ($from2) = $rule->{integer} =~ /^([+-]?\d+)-$/) {
+ unless ($from2 <= $num) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ $info->{range_error} ||
+ $rule->{range_error} ||
+ "\$n must be $from2 or higher");
+ last RULE;
+ }
+ }
+ }
+ if ($rule->{date}) {
+ unless ($data =~ m!^\s*(\d+)[-+/](\d+)[-+/](\d+)\s*$!) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ '$n must be a valid date');
+ last RULE;
+ }
+ my ($day, $month, $year) = ($1, $2, $3);
+ if ($day < 1 || $day > 31) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ '$n must be a valid date - day out of range');
+ last RULE;
+ }
+ if ($month < 1 || $month > 12) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ '$n must be a valid date - month out of range');
+ last RULE;
+ }
+ if ($rule->{mindate} || $rule->{maxdate}) {
+ require DevHelp::Date;
+ my $workdate = sprintf("%04d-%02d-%02d", $year, $month, $day);
+ if ($rule->{mindate}) {
+ my $mindate = DevHelp::Date::dh_parse_date_sql($rule->{mindate});
+ if ($workdate le $mindate) {
+ $errors->{$field} =
+ _make_error($field, $info, $rule,
+ $info->{mindatemsg} || $rule->{mindatemsg} || '$n is too early');
+ }
+ }
+ if (!$errors->{$field} && $rule->{maxdate}) {
+ my $maxdate = DevHelp::Date::dh_parse_date_sql($rule->{maxdate});
+ if ($workdate ge $maxdate) {
+ $errors->{$field} =
+ _make_error($field, $info, $rule,
+ $info->{mindatemsg} || $rule->{maxdatemsg} || '$n is too late');
+ }
+ }
+ }
+ }
+ if ($rule->{confirm}) {
+ my $other = $self->param($rule->{confirm});
+ unless ($other eq $data) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ q!$n doesn't match the password!);
+ last RULE;
+ }
+ }
+ if ($rule->{ccexpiry}) {
+ (my $year_field = $field) =~ s/month/year/;
+
+ unless ($data =~ /^\s*\d+\s*$/) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ q!$n month isn't a number!);
+ last RULE;
+ }
+ my $year = $self->param($year_field);
+ unless (defined $year && $year =~ /\s*\d+\s*$/) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ q!$n year isn't a number!);
+ last RULE;
+ }
+ my ($now_year, $now_month) = (localtime)[5, 4];
+ $now_year += 1900;
+ ++$now_month;
+ if ($year < $now_year || $year == $now_year && $data < $now_month) {
+ $errors->{$field} = _make_error($field, $info, $rule,
+ q!$n is in the past, your card has expired!);
+ last RULE;
+ }
+ }
+ }
+ }
+}
+
+sub _make_error {
+ my ($field, $info, $rule, $message) = @_;
+
+ $message ||= $rule->{error} || 'Validation error on field $n';
+
+ my $name = $info->{description} || $field;
+ $message =~ s/\$n/$name/g;
+
+ return $message;
+}
+
+sub _get_cfg_fields {
+ my ($rules, $cfg, $section, $field_hash) = @_;
+
+ $rules->{rules} = {};
+ $rules->{fields} = {};
+
+ my $cfg_fields = $rules->{fields};
+
+ my $fields = $cfg->entry($section, 'fields', '');
+ my @names = ( split(/,/, $fields), keys %$field_hash );
+
+ for my $field (@names) {
+ for my $cfg_name (qw(required rules description required_error range_error mindatemsg maxdatemsg)) {
+ my $value = $cfg->entry($section, "${field}_$cfg_name");
+ if (defined $value) {
+ $cfg_fields->{$field}{$cfg_name} = $value;
+ }
+ }
+ }
+}
+
+sub _get_cfg_rule {
+ my ($self, $rulename) = @_;
+
+ my %rule = $self->{cfg}->entries("Validation Rule $rulename");
+
+ keys %rule or return;
+
+ \%rule;
+}
+
+sub dh_fieldnames {
+ my ($cfg, $section, $fields) = @_;
+
+ # this needs to be obsoleted now that dh_validate() checks the config
+
+ for my $field (keys %$fields) {
+ my $desc = $cfg->entry($section, $field);
+ defined $desc and $fields->{$field}{description} = $desc;
+ }
+}
+
+package DevHelp::Validate::CGI;
+use vars qw(@ISA);
+@ISA = qw(DevHelp::Validate);
+
+sub param {
+ my ($self, $field) = @_;
+
+ $self->{cgi}->param($field);
+}
+
+package DevHelp::Validate::Hash;
+use vars qw(@ISA);
+@ISA = qw(DevHelp::Validate);
+
+sub param {
+ my ($self, $field) = @_;
+
+ my $value = $self->{hash}{$field};
+
+ defined $value or return;
+
+ if (ref $value eq 'ARRAY') {
+ return @$value;
+ }
+
+ return $value;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+DevHelp::Validate - handy configurable validation, I hope
+
+=head1 SYNOPSIS
+
+ use DevHelp::Validate qw(dh_validate);
+
+ dh_validate($cgi, \%errors, \%rules, $cfg)
+ or display_errors(..., \%errors);
+
+=head1 DESCRIPTION
+
+=head1 RULES PARAMETER
+
+The rules parameter is a hash with 2 keys:
+
+=over
+
+=item fields
+
+A hash of field names, for each of which the value is a hash.
+
+Each hash can have the following keys:
+
+=over
+
+=item rules
+
+A simple rule name, a ';' separated list of rule names or an array
+ref.
+
+=item description
+
+A short description of the field, for use in error messages.
+
+=back
+
+=item rules
+
+A hash of rules. See the rules description under L<CONFIGURED
+VALIDATON>.
+
+=back
+
+=head1 CONFIGURED VALIDATION
+
+Rules can be configured in the database.
+
+For the specified section name, each key is a CGI field name.
+
+The values of those keys gives the name of a validation rule, a string
+id for internationlization of the field description and a default
+field description, separated by commas.
+
+Each validation rule name has a corresponding section, [Validate Rule
+I<rule-name>], which describes the rule. Rule names can also refer to
+built-in rules,
+
+Values in the validation rule section are:
+
+=over
+
+=item required
+
+If this is non-zero the field is required.
+
+=item match
+
+If present, this is used as a regular expression the field must match.
+
+=item error
+
+Message returned as the error if the field fails validation.
+
+=item integer
+
+If set to 1, simply ensures the value is an integer.
+
+If set to a range I<integer>-I<integer> then ensures the value is an
+integer in that range.
+
+=item date
+
+If set to 1, simply validates the value as a date.
+
+=back
+
+=head1 AUTHOR
+
+Tony Cook <tony@develop-help.com>
+
+=cut
randomId cancelled userId paymentType
customInt1 customInt2 customInt3 customInt4 customInt5
customStr1 customStr2 customStr3 customStr4 customStr5
- instructions billTelephone billFacsimile billEmail/;
+ instructions billTelephone billFacsimile billEmail
+ siteuser_id affiliate_code/;
}
=item siteuser
return ( SiteUsers->getBy(userId=>$self->{userId}) )[0];
}
+sub items {
+ my ($self) = @_;
+
+ require BSE::TB::OrderItems;
+ return BSE::TB::OrderItems->getBy(orderId => $self->{id});
+}
+
1;
-package OrderItem;
+package BSE::TB::OrderItem;
use strict;
# represents an order line item from the database
use Squirrel::Row;
sub columns {
return qw/id productId orderId units price wholesalePrice gst options
- customInt1 customInt2 customInt3 customStr1 customStr2 customStr3/;
+ customInt1 customInt2 customInt3 customStr1 customStr2 customStr3
+ title summary subscription_id subscription_period/;
}
1;
-package OrderItems;
+package BSE::TB::OrderItems;
use strict;
use Squirrel::Table;
use vars qw(@ISA $VERSION);
@ISA = qw(Squirrel::Table);
sub rowClass {
- return 'OrderItem';
+ return 'BSE::TB::OrderItem';
}
1;
sub columns {
return ($_[0]->SUPER::columns(),
- qw/articleId summary leadTime retailPrice wholesalePrice gst options/ );
+ qw/articleId summary leadTime retailPrice wholesalePrice gst options
+ subscription_id subscription_period subscription_usage
+ subscription_required/ );
}
sub bases {
return { articleId=>{ class=>'Article'} };
}
+sub subscription_required {
+ my ($self) = @_;
+
+ my $id = $self->{subscription_required};
+ return if $id == -1;
+
+ require BSE::TB::Subscriptions;
+ return BSE::TB::Subscriptions->getByPkey($id);
+}
+
1;
return Orders->getBy(userId => $self->{userId});
}
+# check if the user is subscribed to the given subscription
+sub subscribed_to {
+ my ($self, $sub) = @_;
+
+ return; # PH for now, not subscribed
+}
+
+# check if the user is subscribed to the given subscription, and allow
+# for the max_lapsed grace period
+sub subscribed_to_grace {
+ my ($self, $sub) = @_;
+
+ return; # PH for now, not subscribed
+}
+
1;
print STDERR " > perform $func $args\n" if DEBUG > 1;
- my $value = $self->low_perform($acts, $func, $args, $orig);
+ my $value;
+ eval {
+ $value = $self->low_perform($acts, $func, $args, $orig);
+ };
+
+ if ($@) {
+ my $msg = $@;
+ $msg =~ /^ENOIMPL\b/
+ and return $orig;
+ print STDERR "Eval error in cond: $msg\n";
+ $msg =~ s/([<>&])/"&#".ord($1).";"/ge;
+ return "<!-- ** $msg ** -->";
+ }
unless (defined $value) {
cluck "** undefined value returned by $func $args **";
use BSE::Cfg;
use BSE::Util::Tags qw(tag_hash);
-
my $cfg = BSE::Cfg->new();
my $subject = $cfg->entry('shop', 'subject', $SHOP_MAIL_SUBJECT);
use constant PAYMENT_CC => 0;
use constant PAYMENT_CHEQUE => 1;
use constant PAYMENT_CALLME => 2;
-# my %valid_payment_types =
-# (
-# PAYMENT_CC() =>1,
-# PAYMENT_CHEQUE() =>1,
-# PAYMENT_CALLME() =>1
-# );
-# my %payment_names = ;
my $urlbase = $cfg->entryVar('site', 'url');
my $securlbase = $cfg->entryVar('site', 'secureurl');
recalc=>\&recalc,
recalculate=>\&recalc,
purchase=>\&purchase,
- prePurchase=>\&prePurchase,
+ #prePurchase=>\&prePurchase,
);
for my $key (keys %steps) {
$today le $comp_expire
or return show_cart("Product has expired");
$product->{listed} or return show_cart("Product not available");
+
+ my $user = get_siteuser(\%session, $cfg, $CGI::Q);
+ # need to be logged on if it has any subs
+ if ($product->{subscription_id} != -1 && !$user) {
+ refresh_logon("You must be logged on to add this product to your cart",
+ 'prodlogon');
+ return;
+ }
+ if ($product->{subscription_required} != -1) {
+ my $sub = $product->subscription_required;
+ if ($user) {
+ unless ($user->subscribed_to($sub)) {
+ show_cart("You must be subscribed to $sub->{title} to purchase this product");
+ return;
+ }
+ }
+ else {
+ refresh_logon("You must be logged on and subscribed to $sub->{title} to add this product to your cart",
+ 'prodlogonsub');
+ return;
+ }
+ }
# we need a natural integer quantity
$quantity =~ /^\d+$/
# processes the CC information and then displays the order complete
# information
# BUG!!: this duplicates the code in purchase() a great deal
-sub prePurchase {
-
- my $cust_class = custom_class($cfg);
- my @required = $cust_class->required_fields($CGI::Q, $session{custom}, $cfg);
- for my $field (@required) {
- defined(param($field)) && length(param($field))
- or return checkout("Field $field is required", 1);
- }
- if (grep /email/, @required) {
- defined(param('email')) && param('email') =~ /.\@./
- or return checkout("Please enter a valid email address", 1);
- }
+# sub prePurchase {
+
+# my $cust_class = custom_class($cfg);
+# my @required = $cust_class->required_fields($CGI::Q, $session{custom}, $cfg);
+# for my $field (@required) {
+# defined(param($field)) && length(param($field))
+# or return checkout("Field $field is required", 1);
+# }
+# if (grep /email/, @required) {
+# defined(param('email')) && param('email') =~ /.\@./
+# or return checkout("Please enter a valid email address", 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");
- }
- else {
- (my $comp_release = $product->{release}) =~ s/ .*//;
- (my $comp_expire = $product->{expire}) =~ s/ .*//;
- $comp_release le $today
- or return show_cart("'$product->{title}' has not been released yet");
- $today le $comp_expire
- or return show_cart("'$product->{title}' has expired");
- $product->{listed}
- or return show_cart("'$product->{title}' not 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};
- }
- use BSE::Util::SQL qw(now_sqldatetime);
- $order{orderDate} = now_sqldatetime();
-
- if (my ($msg, $id) = need_logon($cfg, \@cart, \@products, \%session, $CGI::Q)) {
- refresh_logon($msg, $id);
- return;
- }
-
- $order{total} += $cust_class->total_extras(\@cart, \@products,
- $session{custom}, $cfg, 'final');
- ++$session{changed};
- # blank anything else
- for my $column (@columns) {
- defined $order{$column} or $order{$column} = '';
- }
- # make sure the user can't set these behind our backs
- $order{filled} = 0;
- $order{paidFor} = 0;
+# use BSE::TB::Orders;
+# use BSE::TB::OrderItems;
+
+# # 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 = BSE::TB::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");
+# }
+# else {
+# (my $comp_release = $product->{release}) =~ s/ .*//;
+# (my $comp_expire = $product->{expire}) =~ s/ .*//;
+# $comp_release le $today
+# or return show_cart("'$product->{title}' has not been released yet");
+# $today le $comp_expire
+# or return show_cart("'$product->{title}' has expired");
+# $product->{listed}
+# or return show_cart("'$product->{title}' not 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};
+# }
+# use BSE::Util::SQL qw(now_sqldatetime);
+# $order{orderDate} = now_sqldatetime();
+
+# if (my ($msg, $id) = need_logon($cfg, \@cart, \@products, \%session, $CGI::Q)) {
+# refresh_logon($msg, $id);
+# return;
+# }
+
+# $order{total} += $cust_class->total_extras(\@cart, \@products,
+# $session{custom}, $cfg, 'final');
+# ++$session{changed};
+# # blank anything else
+# for my $column (@columns) {
+# defined $order{$column} or $order{$column} = '';
+# }
+# # make sure the user can't set these behind our backs
+# $order{filled} = 0;
+# $order{paidFor} = 0;
- # this should be hard to guess
- $order{randomId} = md5_hex(time().rand().{}.$$);
-
- # check if a customizer has anything to do
- eval {
- $cust_class->order_save($CGI::Q, \%order, \@cart, \@products,
- $session{custom}, $cfg);
- ++$session{changed};
- };
- if ($@) {
- return checkout($@, 1);
- }
-
- # 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 @options;
- my $option_index;
- my %acts;
- %acts =
- (
- iterate_items_reset => sub { $item_index = -1; },
- iterate_items =>
- sub {
- if (++$item_index < @items) {
- $option_index = -1;
- @options = cart_item_opts($items[$item_index],
- $products[$item_index]);
- return 1;
- }
- return 0;
- },
- item=> sub { CGI::escapeHTML($items[$item_index]{$_[0]}); },
- product =>
- sub {
- my $value = $products[$item_index]{$_[0]};
- defined($value) or $value = '';
- CGI::escapeHTML($value);
- },
- extended =>
- sub {
- my $what = $_[0] || 'retailPrice';
- $items[$item_index]{units} * $items[$item_index]{$what};
- },
- 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);
- },
- old => sub { '' },
- _format =>
- sub {
- my ($value, $fmt) = @_;
- if ($fmt =~ /^m(\d+)/) {
- return sprintf("%$1s", sprintf("%.2f", $value/100));
- }
- elsif ($fmt =~ /%/) {
- return sprintf($fmt, $value);
- }
- },
- iterate_options_reset => sub { $option_index = -1 },
- iterate_options => sub { ++$option_index < @options },
- option => sub { CGI::escapeHTML($options[$option_index]{$_[0]}) },
- ifOptions => sub { @options },
- options => sub { nice_options(@options) },
- );
- # this should be reset once the order has been paid
- $session{orderPayment} = $order->{id};
+# # this should be hard to guess
+# $order{randomId} = md5_hex(time().rand().{}.$$);
+
+# # check if a customizer has anything to do
+# eval {
+# $cust_class->order_save($CGI::Q, \%order, \@cart, \@products,
+# $session{custom}, $cfg);
+# ++$session{changed};
+# };
+# if ($@) {
+# return checkout($@, 1);
+# }
+
+# # load up the database
+# my @data = @order{@columns};
+# shift @data; # lose the dummy id
+# my $order = BSE::TB::Orders->add(@data)
+# or die "Cannot add order";
+# my @items;
+# my @item_cols = BSE::TB::OrderItem->columns;
+# for my $row (@cart) {
+# $row->{orderId} = $order->{id};
+# my @data = @$row{@item_cols};
+# shift @data;
+# push(@items, BSE::TB::OrderItems->add(@data));
+# }
+
+# my $item_index = -1;
+# my @options;
+# my $option_index;
+# my %acts;
+# %acts =
+# (
+# iterate_items_reset => sub { $item_index = -1; },
+# iterate_items =>
+# sub {
+# if (++$item_index < @items) {
+# $option_index = -1;
+# @options = cart_item_opts($items[$item_index],
+# $products[$item_index]);
+# return 1;
+# }
+# return 0;
+# },
+# item=> sub { CGI::escapeHTML($items[$item_index]{$_[0]}); },
+# product =>
+# sub {
+# my $value = $products[$item_index]{$_[0]};
+# defined($value) or $value = '';
+# CGI::escapeHTML($value);
+# },
+# extended =>
+# sub {
+# my $what = $_[0] || 'retailPrice';
+# $items[$item_index]{units} * $items[$item_index]{$what};
+# },
+# 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);
+# },
+# old => sub { '' },
+# _format =>
+# sub {
+# my ($value, $fmt) = @_;
+# if ($fmt =~ /^m(\d+)/) {
+# return sprintf("%$1s", sprintf("%.2f", $value/100));
+# }
+# elsif ($fmt =~ /%/) {
+# return sprintf($fmt, $value);
+# }
+# },
+# iterate_options_reset => sub { $option_index = -1 },
+# iterate_options => sub { ++$option_index < @options },
+# option => sub { CGI::escapeHTML($options[$option_index]{$_[0]}) },
+# ifOptions => sub { @options },
+# options => sub { nice_options(@options) },
+# );
+# # this should be reset once the order has been paid
+# $session{orderPayment} = $order->{id};
- page('checkoutcard.tmpl', \%acts);
-}
+# page('checkoutcard.tmpl', \%acts);
+# }
sub tag_ifPayment {
my ($payment, $types_by_name, $args) = @_;
my @pay_types = payment_types($cfg);
my %pay_types = map { $_->{id} => $_ } @pay_types;
my %types_by_name = map { $_->{name} => $_->{id} } @pay_types;
- use Data::Dumper;
- print STDERR Dumper \%pay_types;
+ #use Data::Dumper;
+ #print STDERR Dumper \%pay_types;
my @payment_types = map $_->{id}, grep $_->{enabled}, @pay_types;
if ($noencrypt) {
@payment_types = grep $_ ne PAYMENT_CC, @payment_types;
or return checkout("Please enter a credit card number", 1);
}
- use Orders;
- use Order;
- use OrderItems;
- use OrderItem;
+ use BSE::TB::Orders;
+ use BSE::TB::OrderItems;
# map some form fields to order field names
my %field_map =
@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 = BSE::TB::Order->columns;
my %columns;
@columns{@columns} = @columns;
defined $ccNumber or $ccNumber = '';
my $ccExpiry = param('cardExpiry');
defined $ccExpiry or $ccExpiry = '';
+ $order{affiliate_code} = defined $session{affiliate_code} ?
+ $session{affiliate_code} : '';
use Digest::MD5 'md5_hex';
$ccNumber =~ tr/0-9//cd;
$order{total} = 0;
$order{gst} = 0;
$order{wholesale} = 0;
+ $order{shipping_cost} = 0;
my @products;
my $today = now_sqldate();
for my $item (@cart) {
$order{randomId} = md5_hex(time().rand().{}.$$);
# check if a customizer has anything to do
+ # if it sets shipping cost it must also update the total
eval {
my %custom = %{$session{custom}};
$cust_class->order_save($CGI::Q, \%order, \@cart, \@products,
$order{total} += $cust_class->total_extras(\@cart, \@products,
$session{custom}, $cfg, 'final');
+ my %subscribing_to;
+
# load up the database
my @data = @order{@columns};
shift @data; # lose the dummy id
- my $order = Orders->add(@data)
+ my $order = BSE::TB::Orders->add(@data)
or die "Cannot add order";
my @items;
- my @item_cols = OrderItem->columns;
- for my $row (@cart) {
+ my @item_cols = BSE::TB::OrderItem->columns;
+ my @prod_xfer = qw/title summary subscription_id subscription_period/;
+ for my $row_num (0..$#cart) {
+ my $row = $cart[$row_num];
+ my $product = $products[$row_num];
$row->{orderId} = $order->{id};
+
+ # store product data too
+ @$row{@prod_xfer} = @{$product}{@prod_xfer};
+
my @data = @$row{@item_cols};
+
shift @data;
- push(@items, OrderItems->add(@data));
+ push(@items, BSE::TB::OrderItems->add(@data));
+
+# my $sub = $product->subscription;
+# if ($sub) {
+# $subscribing_to{$sub->{text_id}} = $sub;
+# }
}
my $item_index = -1;
ifOptions => sub { @options },
options => sub { nice_options(@options) },
ifPayment => [ \&tag_ifPayment, $order->{paymentType}, \%types_by_name ],
+ #ifSubscribingTo => [ \&tag_ifSubscribingTo, \%subscribing_to ],
);
for my $type (@pay_types) {
my $id = $type->{id};
my $name = $type->{name};
$acts{"if${name}Payment"} = $order->{paymentType} == $id;
}
- send_order($order, \@items, \@products, $noencrypt);
+ send_order($order, \@items, \@products, $noencrypt, \%subscribing_to);
$session{cart} = []; # empty the cart
page('checkoutfinal.tmpl', \%acts);
}
+# sub tag_ifSubscribingTo {
+# my ($subscribing_to, $args) = @_;
+
+# exists $subscribing_to->{$args};
+# }
+
sub tag_with_wrap {
my ($args, $text) = @_;
my $margin = $args =~ /^\d+$/ && $args > 30 ? $args : 70;
require Text::Wrap;
+ # do it twice to prevent a warning
+ $Text::Wrap::columns = $margin;
$Text::Wrap::columns = $margin;
return Text::Wrap::fill('', '', split /\n/, $text);
# sends the email order confirmation and the PGP encrypted
# email to the site owner
sub send_order {
- my ($order, $items, $products, $noencrypt) = @_;
+ my ($order, $items, $products, $noencrypt, $subscribing_to) = @_;
my %extras = $cfg->entriesCS('extra tags');
for my $key (keys %extras) {
ifOptions => sub { @options },
options => sub { nice_options(@options) },
with_wrap => \&tag_with_wrap,
+ ifSubscribingTo => [ \&tag_ifSubscribingTo, $subscribing_to ],
);
my $mailer = BSE::Mail->new(cfg=>$cfg);
=head1 CHANGES
+=head2 0.14_24
+
+This release includes some structural changes to article editing,
+please test before deploying it.
+
+=over
+
+=item *
+
+doing a sort of all children wouldn't include the unreleased
+(step)childen in the sort (#389)
+
+=item *
+
+with access control enabled, using the reorder.pl script while not
+logged (including due to a cookie timeout) on would produce a server
+error (#419)
+
+=item *
+
+the Orders / Order / OrderItems / OrderItem classes are now
+BSE::TB::Orders / BSE::TB::Order / BSE::TB::OrderItems /
+BSE::TB::OrderItem, to try to use a more consistent naming system and
+clean up the top level namespace
+
+=item *
+
+the prePurchase target has been disabled in shop.pl, since it's
+effectively unmaintained, and probably completely broken
+
+=item *
+
+updated the document list of session values in BSE::Session.
+
+=item *
+
+defaults (both internal and configured) are now used to set
+article/product fields on creation, this should allow simplified
+creation templates to omit fields that don't need to be explicitly set
+
+=item *
+
+the warning about $Text::Wrap::columns only appearing once should
+disappear
+
+=item *
+
+a shipping_cost column has been added to the order table. This is not
+set by BSE at all yet, but is available for use by custom order save
+code.
+
+=item *
+
+some fields and code have been added to support subscriptions (no, not
+the newsletter stuff)
+
+=item *
+
+removed some debug dump code from the shop
+
+=item *
+
+"link title" links now include ".html" at the end to allow Google to
+index them
+
+=item *
+
+some preperatory work has been done to handle affiliates and
+subscriptions
+
+=back
+
=head2 0.14_23
=over
=item *
remove blank lines from the error messages produced on the admin user
-administration pages
+administration pages (#382)
=item *
.table { background-color: #666666}
h3 { font-size: 14px}
h4 { font-size: 12px}
+.version { font-size: 10px }
\ No newline at end of file
</td>
<td nowrap bgcolor="#FFFFFF" valign="top"><:help product thumb:></td>
</tr>
+ <tr>
+ <th nowrap align="left" bgcolor="#FFFFFF">Purchase subscribes to:</th>
+ <td nowrap bgcolor="#FFFFFF">
+ <select name="subscription_id">
+ <option value="-1">(nothing)</option>
+<:iterator begin subscriptions:>
+ <option value="<:subscription subscription_id:>"><:subscription title:></option>
+<:iterator end subscriptions:>
+ </select> for <input type="text" name="subscription_period" value="<:old subscription_period" /><:error_img subscription_period:> months.
+ </td>
+ <td nowrap bgcolor="#FFFFFF"><:help product subscription_id:></td>
+ </tr>
</table>
</td>
</tr>
</head>
<body>
<:wrap here:>
-<p><font size="-1">BSE Release <:release:> - page generated <:today:></font></p>
+<hr />
+<p class="version">BSE Release <:release:> - page generated <:today:></p>
</body></html>
images:></td>
</tr>
<:or Article:><:eif Article:>
+ <!-- tr>
+ <th nowrap align="left" bgcolor="#FFFFFF">Purchase subscribes to:</th>
+ <td nowrap bgcolor="#FFFFFF">
+ <select name="subscription_id">
+ <option value="-1"<:ifEq [old subscription_id] "-1":> selected="selected"<:or:><:eif:>>(nothing)</option>
+<:iterator begin subscriptions:>
+ <option value="<:subscription subscription_id:>"<:ifEq [old subscription_id] [subscription subscription_id]:> selected="selected"<:or:><:eif:>><:subscription title:></option>
+<:iterator end subscriptions:>
+ </select> for <input type="text" name="subscription_period" value="<:old subscription_period:>" size="3" /><:error_img subscription_period:> months.
+ </td>
+ <td nowrap bgcolor="#FFFFFF"><:help product subscription_id:></td>
+ </tr>
+ <tr>
+ <th nowrap align="left" bgcolor="#FFFFFF">Can be used to:</th>
+ <td nowrap bgcolor="#FFFFFF">
+ <select name="subscription_usage">
+ <option value="3"<:ifEq [old subscription_usage] "3":> selected="selected"<:or:><:eif:>>Start or renew a subscription</option>
+ <option value="1"<:ifEq [old subscription_usage] "1":> selected="selected"<:or:><:eif:>>Start a subscription only</option>
+ <option value="2"<:ifEq [old subscription_usage] "2":> selected="selected"<:or:><:eif:>>Renew a subscription only</option>
+ </select>
+ </td>
+ <td nowrap bgcolor="#FFFFFF"><:help product subscription_usage:></td>
+ </tr>
+ <tr>
+ <th nowrap align="left" bgcolor="#FFFFFF">User must be subscribed to:</th>
+ <td nowrap bgcolor="#FFFFFF">
+ <select name="subscription_required">
+ <option value="-1"<:ifEq [old subscription_required] "-1":> selected="selected"<:or:><:eif:>>(nothing)</option>
+<:iterator begin subscriptions:>
+ <option value="<:subscription subscription_id:>"<:ifEq [old subscription_required] [subscription subscription_id]:> selected="selected"<:or:><:eif:>><:subscription title:></option>
+<:iterator end subscriptions:>
+ </select> to purchase this product
+ </td>
+ <td nowrap bgcolor="#FFFFFF"><:help product subscription_id:></td>
+ </tr -->
</table>
</td>
</tr>
<ul><li><a href="/cgi-bin/admin/userlist.pl">Download member list</a></li></ul>
<p> </p>
-<p><a href="/cgi-bin/admin/subs.pl">Subscriptions administration</a></p>
+<p><a href="/cgi-bin/admin/subs.pl">Newsletters administration</a></p>
+
+<p><a href="/cgi-bin/admin/subadmin.pl">Subscriptions administration</a></p>
</td>
<td bgcolor="#FFFFFF">
<:ifUserCan regen_all:>
--- /dev/null
+<:wrap admin/xbase.tmpl title=>"Add Subscription":>
+<h1>Add Subscription</h1>
+<p>
+| <a href="/cgi-bin/admin/menu.pl">Admin menu</a> |
+<:if UserCan bse_subs_list :>
+<a href="<:script:>?a_list=1">List Subscriptions</a> |<:or UserCan:><:eif UserCan:>
+<:ifMessage:>
+<p><b><:message:></b></p>
+<:or:><:eif:>
+
+<form action="<:script:>" method="post" name="addsub">
+<table>
+<tr>
+ <th>Identifier:</th>
+ <td><input type="text" name="text_id" value="<:old text_id:>" /></td>
+ <td><:error_img text_id:><:help addsubscr text_id:></td>
+</tr>
+<tr>
+ <th>Title:</th>
+ <td><input type="text" name="title" value="<:old title:>" /></td>
+ <td><:error_img title:><:help addsubscr title:></td>
+</tr>
+<tr>
+ <th>Description:</th>
+ <td><input type="text" name="description" value="<:old description:>" /></td>
+ <td><:error_img description:><:help addsubscr description:></td>
+</tr>
+<tr>
+ <th>Max Lapsed:</th>
+ <td><input type="text" name="max_lapsed" value="<:old max_lapsed:>" /></td>
+ <td><:error_img max_lapsed:><:help addsubscr max_lapsed:></td>
+</tr>
+<tr>
+ <td colspan="2"><input type="submit" name="a_add" value="Add Subscription" /></td>
+ <td> </td>
+</table>
+</form>
\ No newline at end of file
--- /dev/null
+<:wrap admin/xbase.tmpl title=>"Edit Subscription":>
+<h1>Edit Subscription</h1>
+<p>
+| <a href="/cgi-bin/admin/menu.pl">Admin menu</a> |
+<:if UserCan bse_subs_list :>
+<a href="<:script:>?a_list=1">List Subscriptions</a> |<:or UserCan:><:eif UserCan:>
+<:ifMessage:>
+<p><b><:message:></b></p>
+<:or:><:eif:>
+
+<form action="<:script:>" method="post" name="editsub">
+<input type="hidden" name="subscription_id" value="<:subscription subscription_id:>" />
+<table>
+<tr>
+ <th>Identifier:</th>
+ <td><input type="text" name="text_id" value="<:old text_id subscription text_id:>" /></td>
+ <td><:error_img text_id:><:help addsubscr text_id:></td>
+</tr>
+<tr>
+ <th>Title:</th>
+ <td><input type="text" name="title" value="<:old title subscription title:>" /></td>
+ <td><:error_img title:><:help addsubscr title:></td>
+</tr>
+<tr>
+ <th>Description:</th>
+ <td><input type="text" name="description" value="<:old description subscription description:>" /></td>
+ <td><:error_img description:><:help addsubscr description:></td>
+</tr>
+<tr>
+ <th>Max Lapsed:</th>
+ <td><input type="text" name="max_lapsed" value="<:old max_lapsed subscription max_lapsed:>" /></td>
+ <td><:error_img max_lapsed:><:help addsubscr max_lapsed:></td>
+</tr>
+<tr>
+ <td colspan="2"><input type="submit" name="a_save" value="Save Subscription" /></td>
+ <td> </td>
+</table>
+</form>
\ No newline at end of file
--- /dev/null
+<:wrap admin/xbase.tmpl title=>"Admin Subscriptions":>
+<h1>Admin Subscriptions</h1>
+<p>
+| <a href="/cgi-bin/admin/menu.pl">Admin menu</a> |
+<:if UserCan bse_subs_add :>
+<a href="<:script:>?a_addform=1">Add Subscription</a> |<:or UserCan:><:eif UserCan:>
+<:ifMessage:>
+<p><b><:message:></b></p>
+<:or:><:eif:>
+
+<p>This is for managing periodic subscriptions that a member can buy.
+It has nothing to do with the <a
+href="/cgi-bin/admin/subs.pl">newsletters system.</a></p>
+
+<p>Page <:subscriptions_pagenum:> of <:subscriptions_pagecount:>
+<:ifFirstSubscriptionsPage:><<<< <<<:or:><a href="<:script:>?s=<:sortby:>&r=<:reverse:>&p=1&pp=<:subscriptions_perpage:>"><<<<</a> <a href="<:script:>?s=<:sortby:>&r=<:reverse:>&p=<:prevSubscriptionsPage:>&pp=<:subscriptions_perpage:>"><<</a><:eif:>
+<:iterator begin repeats [subscriptions_pagecount]:>
+<:if Eq [repeat value] [subscriptions_pagenum]:><:repeat value:><:or Eq:><a href="<:script:>?s=<:sortby:>&r=<:reverse:>&p=<:repeat value:>&pp=<:subscriptions_perpage:>"><:repeat value:></a><:eif Eq:>
+<:iterator end repeats:>
+<:ifLastSubscriptionsPage:>>> >>>><:or:><a href="<:script:>?s=<:sortby:>&r=<:reverse:>&p=<:nextSubscriptionsPage:>&pp=<:subscriptions_perpage:>">>></a> <a href="<:script:>?s=<:sortby:>&r=<:reverse:>&p=<:subscriptions_pagecount:>&pp=<:subscriptions_perpage:>">>>>></a><:eif:>
+</p>
+<form method="post" action="<:script:>">
+<table border="0" cellspacing="0" cellpadding="0" bgcolor="#000000" class="table">
+ <tr>
+ <td>
+ <table cellpadding="6" border="0" cellspacing="1">
+ <tr>
+ <th bgcolor="#FFFFFF" nowrap> <a href="<:script:>?<:sorthelp text_id:>&p=<:subscriptions_pagenum:>&pp=<:subscriptions_perpage:>">Id</a></th>
+ <th bgcolor="#FFFFFF" nowrap> <a href="<:script:>?<:sorthelp title:>&p=<:subscriptions_pagenum:>&pp=<:subscriptions_perpage:>">Title</a></th>
+ <th bgcolor="#FFFFFF" nowrap> <a href="<:script:>?<:sorthelp description:>&p=<:subscriptions_pagenum:>&pp=<:subscriptions_perpage:>">Description</a></th>
+ <th bgcolor="#FFFFFF" nowrap> <a href="<:script:>?<:sorthelp max_lapsed:>&p=<:subscriptions_pagenum:>&pp=<:subscriptions_perpage:>">Max Lapse</a></th>
+ </tr>
+ <:if Subscriptions:> <: iterator begin subscriptions :>
+ <tr bgcolor="#FFFFFF">
+ <td nowrap> <a href="<:script:>?a_edit=1&subscription_id=<:isubscription subscription_id:>"><:isubscription text_id:></a></td>
+ <td valign="top"><:isubscription title:></td>
+ <td valign="top"><:isubscription description:></td>
+ <td valign="top"><:isubscription max_lapsed:></td>
+ </tr>
+ <: iterator end subscriptions :>
+ <:or Subscriptions:>
+ <tr bgcolor="#FFFFFF">
+ <td colspan="4" align="center">Your system has no subscriptions.</td>
+ </tr>
+ <:eif Subscriptions:>
+ </table>
+</td>
+</tr>
+</table>
+</form>
+
</head>
<body>
<:wrap here:>
-<p><font size="-1">BSE Release <:release:> - page generated <:today:></font></p>
+<hr />
+<p class="version">BSE Release <:release:> - page generated <:today:></p>
</body></html>
#paths.local_templates=/home/tony/dev/bse/base/altadmin/
-site.secureadmin=1
+site.secureadmin=0
projects / bse.git / commitdiff