site/cgi-bin/modules/BSE/TB/Subscription.pm
site/cgi-bin/modules/BSE/TB/Subscription/Calc.pm
site/cgi-bin/modules/BSE/TB/Subscriptions.pm
+site/cgi-bin/modules/BSE/TB/Tag.pm
+site/cgi-bin/modules/BSE/TB/TagMember.pm
+site/cgi-bin/modules/BSE/TB/TagMembers.pm
+site/cgi-bin/modules/BSE/TB/TagOwner.pm
+site/cgi-bin/modules/BSE/TB/TagOwners.pm
+site/cgi-bin/modules/BSE/TB/Tags.pm
site/cgi-bin/modules/BSE/Template.pm
site/cgi-bin/modules/BSE/Thumb/Imager.pm
site/cgi-bin/modules/BSE/Thumb/Imager/Colourize.pm
site/htdocs/js/admin-ui/debug.js
site/htdocs/js/admin-ui/menu.js
site/htdocs/js/admin.js
+site/htdocs/js/admin_edit.js
site/htdocs/js/admin_messages.js
site/htdocs/js/admin_prodopts.js
site/htdocs/js/admin_siteusers.js
site/templates/admin/image_edit.tmpl Edit a single image
site/templates/admin/include/auditentry.tmpl
site/templates/admin/include/audithead.tmpl
+site/templates/admin/include/edit_common.tmpl
+site/templates/admin/include/site_menu.tmpl
site/templates/admin/interestemail.tmpl
site/templates/admin/locations/add.tmpl
site/templates/admin/locations/delete.tmpl
site/templates/admin/subscr/detail_delete.tmpl
site/templates/admin/subscr/edit.tmpl
site/templates/admin/subscr/list.tmpl
+site/templates/admin/tags.tmpl
site/templates/admin/user_book_seminar.tmpl
site/templates/admin/user_edit_seminar.tmpl
site/templates/admin/user_unbook_seminar.tmpl
site/templates/catalog.tmpl
site/templates/catalog/multi.tmpl
site/templates/catalog/shop_subcat.tmpl
+site/templates/catalog/tagged.tmpl
site/templates/checkout_base.tmpl
site/templates/checkoutcard_base.tmpl
site/templates/checkoutconfirm_base.tmpl
+drop table if exists bse_tag_members;
+drop table if exists bse_tags;
+
-- represents sections, articles
DROP TABLE IF EXISTS article;
CREATE TABLE article (
unique tier_product(tier_id, product_id)
);
+create table bse_tags (
+ id integer not null auto_increment primary key,
+
+ -- typically "BA" for BSE article
+ owner_type char(2) not null,
+ cat varchar(80) not null,
+ val varchar(80) not null,
+
+ unique cat_val(owner_type, cat, val)
+);
+
+create table bse_tag_members (
+ id integer not null auto_increment primary key,
+
+ -- typically BA for BSE article
+ owner_type char(2) not null,
+ owner_id integer not null,
+ tag_id integer not null,
+
+ unique art_tag(owner_id, tag_id),
+ index by_tag(tag_id)
+);
# represents an article from the database
use Squirrel::Row;
use BSE::TB::SiteCommon;
+use BSE::TB::TagOwner;
use vars qw/@ISA/;
-@ISA = qw/Squirrel::Row BSE::TB::SiteCommon/;
+@ISA = qw/Squirrel::Row BSE::TB::SiteCommon BSE::TB::TagOwner/;
use Carp 'confess';
-our $VERSION = "1.003";
+our $VERSION = "1.005";
sub columns {
return qw/id parentid displayOrder title titleImage body
$cfg or confess "No \$cfg supplied to ", ref $self, "->remove";
+ $self->remove_tags;
+
$self->remove_images($cfg);
for my $file ($self->files) {
return $self->flags !~ /D/;
}
+sub tag_owner_type {
+ return "BA";
+}
+
1;
use strict;
use Squirrel::Table;
use vars qw(@ISA $VERSION);
-@ISA = qw(Squirrel::Table);
+require BSE::TB::TagOwners;
+@ISA = qw(Squirrel::Table BSE::TB::TagOwners);
use Article;
-our $VERSION = "1.000";
+our $VERSION = "1.001";
sub rowClass {
return 'Article';
return 1;
}
+sub all_tags {
+ my ($self, @more_rules) = @_;
+ return BSE::TB::Tags->getBy2
+ (
+ [
+ [ owner_type => Article->tag_owner_type ],
+ @more_rules
+ ],
+ { order => "cat, val" },
+ );
+}
+
1;
use BSE::Util::HTML;
use base qw(BSE::Util::DynamicTags);
-our $VERSION = "1.001";
+our $VERSION = "1.002";
sub new {
my ($class, $req, %opts) = @_;
sub generate {
my ($self, $article, $template) = @_;
+ $self->{article} = $article;
my %acts;
if ($self->{admin}) {
%acts = ( $self->tags($article), BSE::Util::Tags->secure($self->{req}) );
return $result;
}
+sub article {
+ $_[0]{article};
+}
+
sub tags {
my ($self, $article) = @_;
use strict;
use base 'BSE::Dynamic::Article';
-our $VERSION = "1.000";
+our $VERSION = "1.001";
# no specific behavious yet
return
(
$self->SUPER::tags($article),
- $self->dyn_article_iterator('dynallprods', 'dynallprod', $article,
+ $self->dyn_article_iterator('dynallprods', 'dynallprod', undef,
\$allprod_index, \$allprod_data),
dynmoveallprod =>
[ tag_dynmove => $self, \$allprod_index, \$allprod_data,
"stepparent=$article->{id}" ],
- $self->dyn_article_iterator('dynallcats', 'dynallcat', $article,
+ $self->dyn_article_iterator('dynallcats', 'dynallcat', undef,
\$allcat_index, \$allcat_data),
dynmoveallcat =>
[ tag_dynmove => $self, \$allcat_index, \$allcat_data,
}
sub iter_dynallprods {
- my ($self, $article, $args) = @_;
+ my ($self, $unused, $args) = @_;
my $result = $self->get_cached('dynallprods');
$result
and return $result;
- $result = $self->access_filter($article->all_visible_products);
+ $result = $self->access_filter($self->article->all_visible_products);
$self->set_cached(dynallprods => $result);
}
sub iter_dynallcats {
- my ($self, $article, $args) = @_;
+ my ($self, $unused, $args) = @_;
my $result = $self->get_cached('dynallcats');
$result
and return $result;
- $result = $self->access_filter($article->all_visible_catalogs);
+ $result = $self->access_filter($self->article->all_visible_catalogs);
$self->set_cached(dynallcats => $result);
use DevHelp::Date qw(dh_parse_date dh_parse_sql_date);
use constant MAX_FILE_DISPLAYNAME_LENGTH => 255;
-our $VERSION = "1.007";
+our $VERSION = "1.009";
=head1 NAME
}
}
+sub iter_tags {
+ my ($self, $article) = @_;
+
+ $article->{id}
+ or return;
+
+ return $article->tag_objects;
+}
+
sub low_edit_tags {
my ($self, $acts, $request, $article, $articles, $msg, $errors) = @_;
my @groups;
my $current_group;
my $it = BSE::Util::Iterate->new;
+ my $ito = BSE::Util::Iterate::Objects->new;
return
(
$request->admin_tags,
$it->make_iterator([ iter_file_stores => $self],
'file_store', 'file_stores'),
ifGroupRequired => [ \&tag_ifGroupRequired, $article, \$current_group ],
+ $ito->make
+ (
+ single => "tag",
+ plural => "tags",
+ code => [ iter_tags => $self, $article ],
+ ),
);
}
$errors{parentid} = "Invalid parent selection (template bug)";
}
$self->validate(\%data, $articles, \%errors);
+
+ my $save_tags = $cgi->param("_save_tags");
+ my @tags;
+ if ($save_tags) {
+ @tags = grep /\S/, $cgi->param("tags");
+ my $error;
+ for my $tag (@tags) {
+ BSE::TB::Tags->valid_name($tag, \$error)
+ or last;
+ }
+ if ($error) {
+ $errors{tags} = "msg:bse/admin/edit/badtag/$error";
+ }
+ }
+
if (keys %errors) {
if ($req->is_ajax) {
return $req->json_content
$article = $articles->getByPkey($article->{id});
}
+ if ($save_tags) {
+ my $error;
+ $article->set_tags(\@tags, \$error);
+ }
+
use Util 'generate_article';
generate_article($articles, $article) if $Constants::AUTO_GENERATE;
[
map $_->data_only, $article->files,
];
+ $article_data->{tags} =
+ [
+ $article->tags, # just the names
+ ];
return $article_data;
}
$article->{template} =~ m|\.\.|) {
$errors{template} = "Please only select templates from the list provided";
}
+
+ my $save_tags = $cgi->param("_save_tags");
+ my @tags;
+ if ($save_tags) {
+ @tags = grep /\S/, $cgi->param("tags");
+ my $error;
+ for my $tag (@tags) {
+ BSE::TB::Tags->valid_name($tag, \$error)
+ or last;
+ }
+ if ($error) {
+ $errors{tags} = "msg:bse/admin/edit/badtag/$error";
+ }
+ }
$self->validate_old($article, \%data, $articles, \%errors, scalar $req->is_ajax)
or return $self->_service_error($req, $article, $articles, undef, \%errors, "FIELD");
$self->save_thumbnail($cgi, $article, \%data)
$article->save();
+ if ($save_tags) {
+ my $error;
+ $article->set_tags(\@tags, \$error);
+ }
+
# fix the kids too
my @extra_regen;
@extra_regen = $self->update_child_dynamic($article, $articles, $req);
package BSE::Edit::Site;
use strict;
-our $VERSION = "1.000";
+our $VERSION = "1.004";
use base 'BSE::Edit::Article';
use BSE::TB::Site;
a_edit_image a_save_image a_order_images filelist fileadd fileswap filedel
filesave a_edit_file a_save_file a_tree a_csrfp a_article a_config);
+my %more_site_actions =
+ (
+ a_tagshow => "req_tagshow",
+ a_tags => "req_tagshow",
+ a_tagrename => "req_tagrename",
+ a_tagdelete => "req_tagdelete",
+ a_tagcleanup => "req_tagcleanup",
+ );
+
sub article_actions {
my ($self) = @_;
my %valid;
@valid{@site_actions} = @actions{@site_actions};
+ @valid{keys %more_site_actions} = values %more_site_actions;
+
%valid;
}
return 0;
}
+sub req_tagshow {
+ my ($self, $req, $article, $articles, $msg, $errors) = @_;
+
+ my $cgi = $req->cgi;
+ my $cat = $cgi->param("cat");
+ my $nocat = $cgi->param("nocat");
+ my @opts;
+ if ($cat) {
+ push @opts, [ like => "cat", "$cat%" ];
+ }
+ elsif ($nocat) {
+ push @opts, [ "=" => "cat", "" ];
+ }
+ my @tags = Articles->all_tags(@opts);
+
+ if ($req->is_ajax) {
+ my @json = map $_->json_data, @tags;
+ if ($cgi->param("showarts")) {
+ for my $i (0 .. $#tags) {
+ my $tag = $tags[$i];
+ my $json = $json[$i];
+ $json->{articles} = [ Articles->getIdsByTag($tag) ];
+ }
+ }
+
+ return $req->json_content
+ (
+ success => 1,
+ tags => \@json,
+ );
+ }
+
+ require BSE::Util::Iterate;
+ my $ito = BSE::Util::Iterate::Objects->new;
+ my $ita = BSE::Util::Iterate::Article->new(cfg => $req->cfg);
+ my $tag;
+ my %acts;
+ %acts =
+ (
+ $ito->make_paged
+ (
+ single => "systag",
+ plural => "systags",
+ data => \@tags,
+ name => "systag",
+ cgi => $req->cgi,
+ perpage_parm => "pp=50",
+ session => $req->session,
+ store => \$tag,
+ ),
+ $ita->make
+ (
+ single => "systagart",
+ plural => "systagarts",
+ code => sub { Articles->getByTag($tag) },
+ nocache => 1,
+ ),
+ $self->low_edit_tags(\%acts, $req, $article, $articles, $msg, $errors),
+ );
+ return $req->response("admin/tags", \%acts);
+}
+
+sub req_tagrename {
+ my ($self, $req, $article, $articles) = @_;
+
+ my $cgi = $req->cgi;
+ my $id = $cgi->param("tag_id");
+ my $name = $cgi->param("name");
+
+ my %errors;
+ my $tag;
+ unless (defined $id && $id =~ /^[0-9]+$/) {
+ $errors{id} = "msg:bse/admin/edit/tags/bad_id";
+ }
+ unless ($errors{id}) {
+ $tag = BSE::TB::Tags->getByPkey($id);
+ unless ($tag) {
+ $errors{tag_id} = "msg:bse/admin/edit/tags/unknown";
+ }
+ }
+
+ my $error;
+ unless (defined $name && BSE::TB::Tags->valid_name($name, \$error)) {
+ my $msgid = "invalid_$error";
+ $errors{name} = "msg:bse/admin/edit/tags/$msgid";
+ }
+
+ if ($tag && !$errors{name}) {
+ my $other = Articles->getTagByName($name);
+ if ($other) {
+ if ($other->id != $tag->id) {
+ $errors{name} = "msg:bse/admin/edit/tags/duplicate:$name";
+ }
+ elsif ($tag->name eq $name) {
+ $errors{name} = "msg:bse/admin/edit/tags/nochange";
+ }
+ }
+ }
+
+ if (%errors) {
+ if ($req->is_ajax) {
+ return $req->field_error(\%errors);
+ }
+ else {
+ return $self->req_tags($req, $article, $articles, undef, \%errors);
+ }
+ }
+
+ my $old_name = $tag->name;
+ $tag->set_name($name);
+ $tag->save;
+
+ if ($req->is_ajax) {
+ return $req->json_content
+ (
+ success => 1,
+ tag => $tag->json_data,
+ );
+ }
+
+ $req->flash("msg:bse/admin/edit/tags/saved", [ $old_name, $tag->name ]);
+ return $self->refresh($article, $cgi, undef, undef, "&a_tags=1");
+}
+
+sub req_tagdelete {
+ my ($self, $req, $article, $articles) = @_;
+
+ my $cgi = $req->cgi;
+ my $id = $cgi->param("tag_id");
+
+ my %errors;
+ my $tag;
+ unless (defined $id && $id =~ /^[0-9]+$/) {
+ $errors{id} = "msg:bse/admin/edit/tags/bad_id";
+ }
+ unless ($errors{id}) {
+ $tag = BSE::TB::Tags->getByPkey($id);
+ unless ($tag) {
+ $errors{tag_id} = "msg:bse/admin/edit/tags/unknown";
+ }
+ }
+
+ if (%errors) {
+ if ($req->is_ajax) {
+ return $req->field_error(\%errors);
+ }
+ else {
+ return $self->req_tags($req, $article, $articles, undef, \%errors);
+ }
+ }
+
+ my $name = $tag->name;
+
+ $tag->remove;
+
+ if ($req->is_ajax) {
+ return $req->json_content
+ (
+ success => 1,
+ );
+ }
+
+ $req->flash("msg:bse/admin/edit/tags/removed", [ $name ]);
+ return $self->refresh($article, $cgi, undef, undef, "&a_tags=1");
+}
+
+sub req_tagcleanup {
+ my ($self, $req, $article, $articles) = @_;
+
+ require BSE::TB::Tags;
+ my $count = 0 + BSE::TB::Tags->cleanup();
+
+ if ($req->is_ajax) {
+ return $req->json_content
+ (
+ success => 1,
+ count => $count,
+ );
+ }
+
+ $req->flash("msg:bse/admin/edit/tags/cleanup", [ $count ]);
+ return $self->refresh($article, $req->cgi, undef, undef, "&a_tags=1");
+}
+
1;
use BSE::Util::HTML;
use Carp qw(cluck confess);
-our $VERSION = "1.003";
+our $VERSION = "1.005";
sub new {
my ($class, %opts) = @_;
return $json_result;
}
+sub field_error {
+ my ($self, $errors) = @_;
+
+ my %errors = %$errors;
+ for my $key (keys %errors) {
+ if ($errors{$key} =~ /^msg:/) {
+ $errors{$key} = $self->_str_msg($errors{$key});
+ }
+ }
+
+ return $self->json_content
+ (
+ success => 0,
+ error_code => "FIELD",
+ errors => \%errors,
+ message => "Fields failed validation",
+ );
+}
+
=item get_csrf_token($name)
Generate a csrf token for the given name.
use strict;
use base 'BSE::Request::Base';
-our $VERSION = "1.002";
+our $VERSION = "1.003";
sub new {
my ($class, %opts) = @_;
$_[0]{is_ajax};
}
-package BSE::Request::Base::Test;
+package BSE::Request::Test::CGI;
+use Carp qw(confess);
sub param {
my $self = shift;
if (@_) {
my $name = shift;
if (@_) {
+ die "Unabled to delete $name key in test";
}
else {
- if (ref $self->{$name}) {
- if (wantarray) {
- return @{$self->{$name}};
+ my $value = $self->{$name};
+ if (defined $value) {
+ if (ref $value) {
+ if (wantarray) {
+ return @{$self->{$name}};
+ }
+ else {
+ return $self->{$name}[-1];
+ }
}
else {
- return $self->{$name}[-1];
+ return $value;
}
}
else {
- return $self->{$name};
+ return;
}
}
}
--- /dev/null
+package BSE::TB::Tag;
+use strict;
+use base 'Squirrel::Row';
+
+our $VERSION = "1.002";
+
+sub columns {
+ qw(id owner_type cat val);
+}
+
+sub table { 'bse_tags' }
+
+sub set_name {
+ my ($self, $name) = @_;
+
+ my ($cat, $val) = BSE::TB::Tags->split_name($name);
+ $self->set_cat($cat);
+ $self->set_val($val);
+}
+
+sub name {
+ my ($self) = @_;
+
+ my $cat = $self->cat;
+ return length $cat ? "$cat: " . $self->val : $self->val;
+}
+
+sub canon_name {
+ my ($self) = @_;
+
+ return lc $self->name;
+}
+
+sub eq_name {
+ my ($self, $name) = @_;
+
+ my $error;
+ my ($canon) = BSE::TB::Tags->canon_name($name, \$error)
+ or return;
+
+ return $canon eq $self->canon_name;
+}
+
+sub remove {
+ my ($self) = @_;
+
+ BSE::DB->single->run("BSE::TB::TagMembers.deleteTag" => $self->id);
+
+ $self->SUPER::remove();
+}
+
+sub json_data {
+ my ($self) = @_;
+
+ my $data = $self->data_only;
+ $data->{name} = $self->name;
+
+ return $data;
+}
+
+1;
--- /dev/null
+package BSE::TB::TagMember;
+use strict;
+use base 'Squirrel::Row';
+
+our $VERSION = "1.000";
+
+sub columns { qw(id owner_type owner_id tag_id) }
+
+sub table { 'bse_tag_members' }
+
+1;
+
--- /dev/null
+package BSE::TB::TagMembers;
+use strict;
+use base 'Squirrel::Table';
+use BSE::TB::TagMember;
+
+our $VERSION = "1.000";
+
+sub rowClass {
+ return 'BSE::TB::TagMember';
+}
+
+sub remove_by_tag {
+ my ($class, $owner, $tag) = @_;
+ BSE::DB->single->run("TagMembers.removeByTag",
+ $owner->tag_owner_type, $owner->id, $tag->id);
+}
+
+sub remove_owned_by {
+ my ($class, $owner) = @_;
+
+ BSE::DB->single->run("TagMembers.remove_owned_by" =>
+ $owner->tag_owner_type, $owner->id);
+}
+
+1;
--- /dev/null
+# mix-in (or close) for classes that keep tags
+# currently just articles
+# the owner class should implement a tag_owner_type method
+package BSE::TB::TagOwner;
+use strict;
+use BSE::TB::Tags;
+use BSE::TB::TagMembers;
+
+our $VERSION = "1.001";
+
+sub set_tags {
+ my ($self, $rtags, $rerror) = @_;
+
+ my @current_tags = $self->tag_objects;
+ my %current = map { $_->canon_name => $_ } @current_tags;
+ my %remove = %current;
+ my %save;
+ my %add;
+ for my $name (@$rtags) {
+ my $work = BSE::TB::Tags->name($name, $rerror);
+ defined $work or return;
+
+ my $lower = lc $work;
+ if ($current{$lower}) {
+ delete $remove{$lower};
+ if (!$save{$lower} && $name ne $current{$lower}->name) {
+ $save{$lower} = $name;
+ }
+ }
+ else {
+ $add{$lower} = $name;
+ }
+ }
+
+ for my $add (values %add) {
+ # look for or make the tag
+ my $tag = BSE::TB::Tags->getByName($self->tag_owner_type, $add);
+ if ($tag) {
+ if ($tag->name ne $add && !$save{lc $add}) {
+ $current{lc $add} = $tag;
+ $save{lc $add} = $add;
+ }
+ }
+ else {
+ $tag = BSE::TB::Tags->make_with_name($self->tag_owner_type, $add);
+ }
+
+ # add the reference
+ BSE::TB::TagMembers->make
+ (
+ owner_type => $self->tag_owner_type,
+ owner_id => $self->id,
+ tag_id => $tag->id,
+ );
+ }
+
+ for my $save (keys %save) {
+ my $new_name = $save{$save};
+ my $tag = $current{$save};
+ $tag->set_name($new_name);
+ $tag->save;
+ }
+
+ # remove any leftovers
+ for my $remove (values %remove) {
+ BSE::TB::TagMembers->remove_by_tag($self, $remove);
+ }
+
+ return 1;
+}
+
+# remove all tags
+sub remove_tags {
+ my ($self) = @_;
+
+ BSE::TB::TagMembers->remove_owned_by($self);
+}
+
+sub tag_objects {
+ my ($self) = @_;
+
+ return BSE::TB::Tags->getSpecial(object_tags => $self->tag_owner_type, $self->id);
+}
+
+sub tags {
+ my ($self) = @_;
+
+ return map $_->name, $self->tag_objects;
+}
+
+sub tag_ids {
+ my ($self) = @_;
+
+ return map $_->{id}, BSE::DB->single->run("Tag_ids.by_owner", $self->tag_owner_type, $self->id);
+}
+
+sub has_tags {
+ my ($self, $rtags) = @_;
+
+ my %my_tag_ids = map { $_ => 1 } $self->tag_ids;
+
+ # make sure we have objects, if there's no tag, we don't have that
+ # tage and can immediately return false
+ for my $tag (@$rtags) {
+ my $work = $tag;
+ unless (ref $work) {
+ $work = BSE::TB::Tags->getByName($self->tag_owner_type, $tag)
+ or return;
+ }
+
+ $my_tag_ids{$tag->id}
+ or return;
+ }
+
+ return 1;
+}
+
+1;
--- /dev/null
+# mix-in (or close) for classes that keep tags
+# currently just articles
+# the owner row class should implement a tag_owner_type method
+package BSE::TB::TagOwners;
+use strict;
+use BSE::TB::Tags;
+use BSE::TB::TagMembers;
+
+our $VERSION = "1.001";
+
+sub getTagByName {
+ my ($self, $name) = @_;
+
+ return BSE::TB::Tags->getByName($self->rowClass->tag_owner_type, $name);
+}
+
+# return articles that use the given tag
+sub getByTag {
+ my ($self, $tag) = @_;
+
+ return $self->getSpecial(byTag => $tag->id);
+}
+
+sub getIdsByTag {
+ my ($self, $tag) = @_;
+
+ return BSE::TB::TagMembers->getColumnBy(owner_id => [ tag_id => $tag->id ]);
+}
+
+1;
--- /dev/null
+package BSE::TB::Tags;
+use strict;
+use base 'Squirrel::Table';
+use BSE::TB::Tag;
+
+our $VERSION = "1.002";
+
+sub rowClass {
+ return 'BSE::TB::Tag';
+}
+
+sub split_name {
+ my ($class, $name) = @_;
+
+ my $cat = "";
+ if ($name =~ s/^([^:]+): *//) {
+ $cat = $1;
+ $cat =~ s/^\s+//;
+ $cat =~ s/\s+$//;
+ }
+ my $value = $name;
+ $value =~ s/^\s+//;
+ $value =~ s/\s+$//;
+
+ return ($cat, $value);
+}
+
+my $bad_char = qr/[\\\/\x00-\x1F\x80-\x9F]/;
+
+sub valid_name {
+ my ($class, $name, $error) = @_;
+
+ unless ($name =~ /\S/) {
+ $$error = "empty";
+ return;
+ }
+
+ my ($cat, $val) = $class->split_name($name);
+
+ if ($cat =~ $bad_char || $val =~ /$bad_char/) {
+ $$error = "badchars";
+ return;
+ }
+
+ return ($cat, $val);
+}
+
+sub make_name {
+ my ($self, $cat, $val) = @_;
+
+ return length $cat ? "$cat: $val" : $val;
+}
+
+sub name {
+ my ($self, $name, $rerror) = @_;
+
+ my ($cat, $val) = $self->valid_name($name, $rerror)
+ or return;
+
+ return $self->make_name($cat, $val);
+}
+
+sub canon_name {
+ my ($self, $name, $error) = @_;
+
+ my $res = $self->name($name, $error);
+ defined $res
+ or return;
+
+ return lc $res;
+}
+
+sub getByName {
+ my ($self, $owner_type, $name) = @_;
+
+ my ($cat, $val) = $self->split_name($name);
+ return $self->getBy(owner_type => $owner_type,
+ cat => $cat,
+ val => $val);
+}
+
+sub make_with_name {
+ my ($self, $owner_type, $name) = @_;
+
+ my ($cat, $val) = $self->split_name($name);
+ return $self->make
+ (
+ owner_type => $owner_type,
+ cat => $cat,
+ val => $val,
+ );
+}
+
+sub cleanup {
+ return BSE::DB->single->run("bseTagsCleanup");
+}
+
+1;
use strict;
use Carp 'confess';
-our $VERSION = "1.002";
+our $VERSION = "1.003";
sub new {
my ($class, %opts) = @_;
sub _field_error {
my ($self, $req, $errors) = @_;
- my %errors = %$errors;
- for my $key (keys %errors) {
- if ($errors{$key} =~ /^msg:/) {
- $errors{$key} = $req->_str_msg($errors{$key});
- }
- }
-
- return $req->json_content
- (
- success => 0,
- error_code => "FIELD",
- errors => \%errors,
- message => "Fields failed validation",
- );
+ return $req->field_error($errors);
}
sub controller_id {
use base 'BSE::TagFormats';
use BSE::CfgInfo qw(custom_class);
-our $VERSION = "1.007";
+our $VERSION = "1.017";
+
+=head1 NAME
+
+BSE::Util::DynamicTags - common dynamic page tags for BSE.
+
+=head1 SYNOPSIS
+
+ # in the code
+ my %acts =
+ (
+ $req->dyn_user_tags(),
+ ...
+ );
+
+ # in the page
+
+ <:usr userId:>
+ ...
+
+=head1 DESCRIPTION
+
+This module defines the common set of tags available on public dynamic
+pages.
+
+=head1 METHODS
+
+=over
+
+=item new
+
+Create a new tags object, accepts a single parameter which is a
+L<BSE::Request> object.
+
+=cut
sub new {
my ($class, $req) = @_;
return bless { req => $req }, $class;
}
-=item Common dynamic tags
-
-=over
-
-=item *
+=item tags
-paid_files, paid_file - iterates over the files the user has paid for.
+Returns the common tags.
=back
$self->dyn_article_iterator('dynallkids_of3', 'dynofallkid3'),
$self->dyn_article_iterator('dynchildren_of', 'dynofchild'),
$self->dyn_iterator('dyncart', 'dyncartitem'),
- $self->dyn_article_iterator('wishlist', 'wishlistentry', $req),
+ $self->dyn_article_iterator('wishlist', 'wishlistentry'),
+ $self->dyn_iterator('dynunused_tagcats', 'dynunused_tagcat'),
+ $self->dyn_iterator('dynunused_tags', 'dynunused_tag'),
+ $self->dyn_iterator('dyntags', 'dyntag'),
url => [ tag_url => $self ],
dyncarttotalcost => [ tag_dyncarttotal => $self, 'total_cost' ],
dyncarttotalunits => [ tag_dyncarttotal => $self, 'total_units' ],
return custom_class($self->cfg)->dynamic_tags($self->req);
}
+=item cfg
+
+Return a cfg object.
+
+=cut
+
sub cfg {
return $_[0]{req}->cfg;
}
+=item cgi
+
+Return the cgi object.
+
+=cut
+
sub cgi {
return $_[0]{req}->cgi;
}
+=item req
+
+Return the request object.
+
+=cut
+
sub req {
return $_[0]{req};
}
+=item admin_mode
+
+Return true if in admin mode.
+
+=cut
+
+sub admin_mode {
+ return 0;
+}
+
+=head1 COMMON DYNAMIC TAGS
+
+=over
+
+=item ifUser
+=synopsis <:if User:><:user userId:><:or:>Not logged in<:eif:>
+
+With parameters, check if there is a user currenly logged in.
+
+Without, check if the given attribute of the currently logged in user
+is a true perl value.
+
+=cut
+
sub tag_ifUser {
my ($req, $args) = @_;
}
}
+=item user
+
+Retrieve an attribute from the currently logged in user.
+
+Returns an empty string if the user isn't logged in or if the
+attribute is unknown.
+
+=cut
+
sub tag_user {
my ($req, $args) = @_;
escape_html($siteuser->{$args});
}
+=item ifUserCanSee
+=synopsis <:ifUserCanSee 3:><a href="/shop/">See the shop</a><:or:><:eif:>
+
+Tests if the currently logged in siteuser has access to the named or
+numbered article.
+
+=cut
+
sub tag_ifUserCanSee {
my ($req, $args) = @_;
$req->siteuser_has_access($article);
}
+=item ifUserMemberOf
+
+Test if the currently logged in user is a member of the named group.
+
+Accepts [] style parameters.
+
+=cut
+
sub tag_ifUserMemberOf {
my ($self, $args, $acts, $func, $templater) = @_;
return $group->contains_user($user);
}
+=item dyntarget
+=synopsis <:dyntarget user a_logon 1:>
+
+Generate a url to the specified script with the given parameters.
+
+Accepts [] style parameters.
+
+=cut
+
sub tag_dyntarget {
my ($self, $args, $acts, $func, $templater) = @_;
return escape_html($req->user_url($script, $target, @options));
}
+=item url
+=synopsis <:url dynofallkid:>
+
+Generate a link to the specified article, taking admin mode into
+account.
+
+=cut
+
sub tag_url {
my ($self, $name, $acts, $func, $templater) = @_;
return escape_html($value);
}
+=item iterator dynlevel1s
+
+Iterate over level 1 articles.
+
+=cut
+
sub iter_dynlevel1s {
my ($self, $unused, $args) = @_;
return $result;
}
+=item iterator dynlevel2s
+
+Iterate over the children of the dynlevel1 article.
+
+=cut
+
sub iter_dynlevel2s {
my ($self, $unused, $args) = @_;
return $result;
}
+=item iterator dynlevel3s
+
+Iterate over the children of the dynlevel2 article.
+
+=cut
+
sub iter_dynlevel3s {
my ($self, $unused, $args) = @_;
return $result;
}
+=item dynallkids_of
+
+Also dynallkids_of2, dynallkids_of3
+
+Iterate over all children of the each of the specified article names
+or ids.
+
+=cut
+
sub iter_dynallkids_of {
my ($self, $unused, $args, $acts, $templater, $state) = @_;
*iter_dynallkids_of2 = \&iter_dynallkids_of;
*iter_dynallkids_of3 = \&iter_dynallkids_of;
+=item dynchildren_of
+
+Iterate over direct children of each of the specified article names or
+ids.
+
+=cut
+
sub iter_dynchildren_of {
my ($self, $unused, $args, $acts, $templater) = @_;
return $self->access_filter( map Articles->listedChildren($_), @ids);
}
+=item iterator dyncart
+
+Iterate over the contents of the cart.
+
+=cut
+
sub iter_dyncart {
my ($self, $unused, $args) = @_;
return $cart->{cart};
}
+=item dyncarttotal
+
+The total cost of the items in the cart, in cents.
+
+=cut
+
sub tag_dyncarttotal {
my ($self, $field, $args) = @_;
return;
}
+=item iterator wishlist
+
+Iterate over the items in the logged in user's wishlist.
+
+=cut
+
sub iter_wishlist {
- my ($self, $req) = @_;
+ my ($self) = @_;
- my $user = $req->siteuser
+ my $user = $self->req->siteuser
or return [];
return [ $user->wishlist ];
}
-sub access_filter {
- my ($self, @articles) = @_;
-
- my $req = $self->{req};
+=item iterator dynunused_tagcats
- my $admin_sees_all = $req->cfg->entry('basic', 'admin_sees_all', 1);
+Iterate over the the tag categories of unused tags in the articles
+selected by the given tags: and filter: parameters.
- $admin_sees_all && $self->{admin} and
- return \@articles;
+You must supply a tags: filter, even if it's just "".
- return [ grep $req->siteuser_has_access($_), @articles ];
-}
+There will be an iteration with an empty I<name> for each tag without
+a category.
-my $cols_re; # cache for below
+If a parameter "onlyone" is supplied then the list of tag categories
+will not include tag categories that appear in the tags filter.
-sub _get_filter {
- my ($self, $rargs) = @_;
+Each entry has:
- if ($$rargs =~ s/filter:\s+(.*)\z//s) {
- my $expr = $1;
- my $orig_expr = $expr;
- unless ($cols_re) {
- require Articles;
- my $cols_expr = '(' . join('|', Article->columns) . ')';
- $cols_re = qr/\[$cols_expr\]/;
- }
- $expr =~ s/$cols_re/\$article->{$1}/g;
- $expr =~ s/ARTICLE/\$article/g;
- #print STDERR "Expr $expr\n";
- my $filter;
- $filter = eval 'sub { my $article = shift; '.$expr.'; }';
- if ($@) {
- print STDERR "** Failed to compile filter expression >>$expr<< built from >>$orig_expr<<\n";
- return;
- }
+=over
- return $filter;
- }
- else {
- return;
- }
-}
+=item * name - name of the category
-sub _do_filter {
- my ($self, $filter, $articles) = @_;
+=item * nocat - a category-less tag
- $filter
- or return $articles;
+=item * ind - a unique key for this category.
- return [ grep $filter->($_), @$articles ];
-}
+=back
-sub _dyn_iterate_reset {
- my ($self, $state, $args, $acts, $name, $templater) = @_;
+=cut
- my $rindex = $state->{rindex};
- my $rdata = $state->{rdata};
- my $method = "iter_$state->{plural}";
- my $filter = $self->_get_filter(\$args);
- $$rdata = $self->
- _do_filter($filter, $self->$method($state->{context}, $args, $acts, $templater, $state));
-
- $$rindex = -1;
+sub iter_dynunused_tagcats {
+ my ($self, $unused, $args, $acts, $templater, $state) = @_;
- $state->{previous} = undef;
- $state->{item} = undef;
- if (@$$rdata) {
- $state->{next} = $$rdata->[0];
+ unless ($args =~ s/^(\w+)\s*//) {
+ print STDERR "dynunused_tagcats: missing iterator name\n";
+ return [];
}
- else {
- $state->{next} = undef;
+
+ my $iter = $1;
+ my $method = "iter_$iter";
+ unless ($self->can($method)) {
+ print STDERR "* Unknown iterator $iter *\n";
+ return [];
}
- 1;
-}
+ my $only_one = $args =~ s/^\s*onlyone\s+//;
-sub _dyn_iterate {
- my ($self, $state) = @_;
+ my $context = $self->{context}{$iter};
+ my %state =
+ (
+ plural => $iter,
+ single => "unknown",
+ context => $context,
+ );
- my $rindex = $state->{rindex};
- my $rdata = $state->{rdata};
- my $single = $state->{single};
- if (++$$rindex < @$$rdata) {
- $state->{previous} = $state->{item};
- $state->{item} = $state->{next};
- if ($$rindex < $#$$rdata) {
- $state->{next} = $$rdata->[$$rindex+1];
+ my $filter = $self->{filter};
+ my $selected_tags = $filter->{tags};
+ my $ignored = $self->_do_filter(\%state, $filter, $self->$method($context, $args, $acts, $templater, \%state));
+ keys %$filter
+ or $self->{filter} = undef;
+
+ my %selected_cats = map { $_ => 1 }
+ map { lc ((BSE::TB::Tags->split_name($_))[0]) }
+ @{$selected_tags || []};
+
+ my %cats;
+ my $tags = $self->{tags}{$iter};
+ TAG:
+ for my $tag (keys %$tags) {
+ my $count = $tags->{$tag};
+ my ($cat, $val) = BSE::TB::Tags->split_name($tag);
+ my $ind = lc(length $cat ? "$cat:" : $val);
+ my $can_cat = lc $cat;
+
+ if ($only_one && length $cat && $selected_cats{$can_cat}) {
+ next TAG;
}
- else {
- $state->{next} = undef;
+
+ unless ($cats{$ind}) {
+ $cats{$ind} =
+ {
+ name => $cat,
+ ind => $ind,
+ vals => [],
+ nocat => (length($cat) == 0),
+ };
}
- $self->{req}->set_article("previous_$single" => $state->{previous});
- $self->{req}->set_article($single => $state->{item});
- $self->{req}->set_article("next_$single" => $state->{next});
- return 1;
+ push @{$cats{$ind}{vals}},
+ {
+ name => $tag,
+ val => $val,
+ cat => $cat,
+ count => $count,
+ };
}
- else {
- $self->{req}->set_article($single => undef);
- return;
+
+ # sort each value set
+ for my $cat (values %cats) {
+ my $newvals = [ sort { lc($a->{val}) cmp lc($b->{val}) } @{$cat->{vals}} ];
+ $cat->{vals} = $newvals;
}
+
+ my $cats =
+ [
+ sort
+ {
+ $b->{nocat} <=> $a->{nocat}
+ || $a->{ind} cmp $b->{ind}
+ } values %cats
+ ];
+
+ return $cats;
}
-sub _dyn_item_low {
- my ($self, $item, $args) = @_;
+=item iterator dynunsed_tags
- $item or return '';
- my $value = $item->{$args};
- defined $value
- or return '';
+Iterate over the unused tags in a category from dynunused_tagcats.
- return escape_html($value);
-}
+Each entry has:
-sub _dyn_item {
- my ($self, $state, $args) = @_;
+=over
- my $rindex = $state->{rindex};
- my $rdata = $state->{rdata};
- my $item = $state->{item};
- unless ($state->{item}) {
- return "** $state->{single} only usable inside iterator $state->{plural} **";
- }
+=item * name - the full name of the tag, including category
- return $self->_dyn_item_low($item, $args);
-}
+=item * cat - the category only
-sub _dyn_next {
- my ($self, $state, $args) = @_;
+=item * val - the value only
- return $self->_dyn_item_low($state->{next}, $args);
-}
+=back
-sub _dyn_previous {
- my ($self, $state, $args) = @_;
+=cut
- return $self->_dyn_item_low($state->{previous}, $args);
+sub iter_dynunused_tags {
+ my ($self, $unused, $args) = @_;
+
+ my $cat = $self->{current}{dynunused_tagcats}
+ or return;
+
+ return $cat->{vals};
}
-sub _dyn_item_object_low {
- my ($self, $item, $args, $state) = @_;
+=item dyntags
+=synopsis <:iterator begin dyntags [lcgi tags]:>
- $item
- or return '';
- $item->can($args)
- or return "* $args not valid for $state->{single} *";
- my $value = $item->$args;
- defined $value
- or return '';
+Iterate over a list of tags.
- return escape_html($value);
-}
+=cut
-sub _dyn_item_object {
- my ($self, $state, $args) = @_;
+sub iter_dyntags {
+ my ($self, $unused, $args, $acts, $templater) = @_;
- unless ($state->{item}) {
- return "** $state->{single} only usable inside iterator $state->{plural} **";
+ my @tags = grep /\S/, map { split '/' } $templater->get_parms($args, $acts);
+
+ my @out;
+ for my $tag (@tags) {
+ my ($cat, $val) = BSE::TB::Tags->split_name($tag);
+
+ push @out,
+ {
+ name => BSE::TB::Tags->make_name($cat, $val),
+ cat => $cat,
+ val => $val
+ };
}
- return $self->_dyn_item_object_low($state->{item}, $args, $state);
+ return \@out;
}
-sub _dyn_next_obj {
- my ($self, $state, $args) = @_;
+sub access_filter {
+ my ($self, @articles) = @_;
- return $self->_dyn_item_object_low($state->{next}, $args, $state);
-}
+ my $req = $self->{req};
-sub _dyn_previous_obj {
- my ($self, $state, $args) = @_;
-
- return $self->_dyn_item_object_low($state->{previous}, $args, $state);
-}
-
-sub _dyn_ifNext {
- my ($self, $state) = @_;
-
- return defined $state->{next};
-}
-
-sub _dyn_ifPrevious {
- my ($self, $state) = @_;
-
- return defined $state->{previous};
-}
-
-sub _dyn_article {
- my ($self, $state, $args) = @_;
-
- my $rindex = $state->{rindex};
- my $rdata = $state->{rdata};
- unless ($state->{item}) {
- return "** $state->{single} only usable inside iterator $state->{plural} **";
- }
-
- my $item = $state->{item}
- or return '';
-
- return tag_article($item, $self->{req}->cfg, $args);
-}
-
-sub _dyn_next_article {
- my ($self, $state, $args) = @_;
-
- $state->{next} or return '';
-
- return tag_article($state->{next}, $self->{req}->cfg, $args);
-}
-
-sub _dyn_previous_article {
- my ($self, $state, $args) = @_;
-
- $state->{previous} or return '';
-
- return tag_article($state->{previous}, $self->{req}->cfg, $args);
-}
-
-sub _dyn_index {
- my ($self, $rindex, $rdata, $single) = @_;
-
- if ($$rindex < 0 || $$rindex >= @$$rdata) {
- return "** $single only valid inside iterator **";
- }
-
- return $$rindex;
-}
-
-sub _dyn_number {
- my ($self, $rindex, $rdata, $single) = @_;
-
- if ($$rindex < 0 || $$rindex >= @$$rdata) {
- return "** $single only valid inside iterator **";
- }
-
- return 1 + $$rindex;
-}
-
-sub _dyn_count {
- my ($self, $rdata, $rindex, $plural, $context, $args, $acts, $name,
- $templater) = @_;
+ my $admin_sees_all = $req->cfg->entry('basic', 'admin_sees_all', 1);
- my $filter = $self->_get_filter(\$args);
- my $method = "iter_$plural";
- my $data = $self->_do_filter($filter, $self->$method($context, $args, $acts, $templater));
+ $admin_sees_all && $self->{admin} and
+ return \@articles;
- return scalar @$data;
+ return [ grep $req->siteuser_has_access($_), @articles ];
}
-sub _dyn_if_first {
- my ($self, $rindex, $rdata) = @_;
+=item dthumbimage
- $$rindex == 0;
-}
+Either:
-sub _dyn_if_last {
- my ($self, $rindex, $rdata) = @_;
+=over
- $$rindex == $#$$rdata;
-}
+C<< dynthumbimage I<article> I<geometry> I<image> I<field> >>
-sub dyn_iterator {
- my ($self, $plural, $single, $context, $rindex, $rdata) = @_;
+or
- my $method = $plural;
- my $index;
- defined $rindex or $rindex = \$index;
- my $data;
- defined $rdata or $rdata = \$data;
- my %state =
- (
- plural => $plural,
- single => $single,
- rindex => $rindex,
- rdata => $rdata,
- context => $context,
- );
- return
- (
- "iterate_${plural}_reset" =>
- [ _dyn_iterate_reset => $self, \%state ],
- "iterate_$plural" =>
- [ _dyn_iterate => $self, \%state ],
- $single =>
- [ _dyn_item => $self, \%state ],
- "${single}_index" =>
- [ _dyn_index => $self, $rindex, $rdata, $single ],
- "${single}_number" =>
- [ _dyn_number => $self, $rindex, $rdata ],
- "${single}_count" =>
- [ _dyn_count => $self, $rindex, $rdata, $plural, $context ],
- "if\u$plural" =>
- [ _dyn_count => $self, $rindex, $rdata, $plural, $context ],
- "ifLast\u$single" => [ _dyn_if_last => $self, $rindex, $rdata ],
- "ifFirst\u$single" => [ _dyn_if_first => $self, $rindex, $rdata ],
- "next_$single" => [ _dyn_next => $self, \%state ],
- "previous_$single" => [ _dyn_previous => $self, \%state ],
- "ifNext\u$single" => [ _dyn_ifNext => $self, \%state ],
- "ifPrevious\u$single" => [ _dyn_ifPrevious => $self, \%state ],
- );
-}
+C<< dthumbimage I<article> I<geometry> I<image> >>
-sub dyn_iterator_obj {
- my ($self, $plural, $single, $context, $rindex, $rdata) = @_;
+=back
- my $method = $plural;
- my $index;
- defined $rindex or $rindex = \$index;
- my $data;
- defined $rdata or $rdata = \$data;
- my %state =
- (
- plural => $plural,
- single => $single,
- rindex => $rindex,
- rdata => $rdata,
- context => $context,
- );
- return
- (
- "iterate_${plural}_reset" =>
- [ _dyn_iterate_reset => $self, \%state ],
- "iterate_$plural" =>
- [ _dyn_iterate => $self, \%state ],
- $single =>
- [ _dyn_item_object => $self, \%state ],
- "${single}_index" =>
- [ _dyn_index => $self, $rindex, $rdata, $single ],
- "${single}_number" =>
- [ _dyn_number => $self, $rindex, $rdata ],
- "${single}_count" =>
- [ _dyn_count => $self, $rindex, $rdata, $plural, $context ],
- "if\u$plural" =>
- [ _dyn_count => $self, $rindex, $rdata, $plural, $context ],
- "ifLast\u$single" => [ _dyn_if_last => $self, $rindex, $rdata ],
- "ifFirst\u$single" => [ _dyn_if_first => $self, $rindex, $rdata ],
- "next_$single" => [ _dyn_next_obj => $self, \%state ],
- "previous_$single" => [ _dyn_previous_obj => $self, \%state ],
- "ifNext\u$single" => [ _dyn_ifNext => $self, \%state ],
- "ifPrevious\u$single" => [ _dyn_ifPrevious => $self, \%state ],
- );
-}
+Similar to thumbimage/gthumbimage, this allows you to retrieve images
+from a given article, which article can either be a number or a named
+article in the current context.
-sub _dyn_article_move {
- my ($self, $state, $args, $acts, $func, $templater) = @_;
+geometry and field are as for the static thumbimage tag.
- $state->{parentid}
- or return '';
+image is a comma separated list of match operators, eg:
- return $self->tag_dynmove($state->{rindex}, $state->{rdata},
- "stepparent=$state->{parentid}",
- $args, $acts, $templater);
-}
+ <:dthumbimage result search search,/^display_$/,1 :>
-sub dyn_article_iterator {
- my ($self, $plural, $single, $context, $rindex, $rdata) = @_;
+on a search page will display either the image with an id of search,
+the first image found with an identifier starting with "display_" or
+the first image of the article.
- my $method = $plural;
- my $index;
- defined $rindex or $rindex = \$index;
- my $data;
- defined $rdata or $rdata = \$data;
- my %state =
- (
- plural => $plural,
- single => $single,
- rindex => $rindex,
- rdata => $rdata,
- context => $context,
- );
- return
- (
- "iterate_${plural}_reset" =>
- [ _dyn_iterate_reset => $self, \%state ],
- "iterate_$plural" =>
- [ _dyn_iterate => $self, \%state],
- $single =>
- [ _dyn_article => $self, \%state ],
- "${single}_index" =>
- [ _dyn_index => $self, $rindex, $rdata, $single ],
- "${single}_number" =>
- [ _dyn_number => $self, $rindex, $rdata ],
- "${single}_count" =>
- [ _dyn_count => $self, $rindex, $rdata, $plural, $context ],
- "if\u$plural" =>
- [ _dyn_count => $self, $rindex, $rdata, $plural, $context ],
- "ifLast\u$single" => [ _dyn_if_last => $self, $rindex, $rdata ],
- "ifFirst\u$single" => [ _dyn_if_first => $self, $rindex, $rdata ],
- "next_$single" => [ _dyn_next_article => $self, \%state ],
- "previous_$single" => [ _dyn_previous_article => $self, \%state ],
- "ifNext\u$single" => [ _dyn_ifNext => $self, \%state ],
- "ifPrevious\u$single" => [ _dyn_ifPrevious => $self, \%state ],
- "move_$single" => [ _dyn_article_move => $self, \%state ],
- );
-}
+Possible match operators are:
-sub get_cached {
- my ($self, $id) = @_;
+=over
- return $self->{_cache}{$id};
-}
+=item *
-sub set_cached {
- my ($self, $id, $value) = @_;
+/regexp/ - a regular expression matched against the image identifier
- $self->{_cache}{$id} = $value;
-}
+=item *
-sub _cart {
- my ($self) = @_;
+index - a numeric image index, where 1 is the first image
- my $dyncart = $self->get_cached('cart');
- $dyncart and return $dyncart;
+=item *
- my $cart = $self->{req}->session->{cart}
- or return { cart => [], total_cost => 0, total_units => 0 };
+identifier - a literal image identifier
- my @cart;
- my $total_cost = 0;
- my $total_units = 0;
- for my $item (@$cart) {
- require Products;
- my $product = Products->getByPkey($item->{productId});
- my $extended = $product->price(user => scalar $self->{req}->siteuser)
- * $item->{units};
- my $link = $product->link;
- $link =~ /^\w+:/
- or $link = $self->{req}->cfg->entryErr('site', 'url') . $link;
- push @cart,
- {
- ( map { $_ => $product->{$_} } $product->columns ),
- %$item,
- extended => $extended,
- link => $link,
- };
- $total_cost += $extended;
- $total_units += $item->{units};
- }
- my $result =
- {
- cart => \@cart,
- total_cost => $total_cost,
- total_units => $total_units,
- };
- $self->set_cached(cart => $result);
+=back
- return $result;
-}
+=cut
sub tag_dthumbimage {
my ($self, $args) = @_;
return $self->_thumbimage_low($geometry, $im, $field, $self->{req}->cfg);
}
-sub tag_dgthumbimage {
- my ($self, $args, $acts, $func, $templater) = @_;
+=item dgthumbimage
+
+=over
+
+C<<dgthumbimage I<geometry> I<name> I<field> >>
+
+C<<dgthumbimage I<geometry> I<name> >>
+
+=back
+
+Format a thumbnail for a global image, in dynamic context.
+
+=cut
+
+sub tag_dgthumbimage {
+ my ($self, $args, $acts, $func, $templater) = @_;
my ($geometry, $name, $field) =
DevHelp::Tags->get_parms($args, $acts, $templater);
return [];
}
+=item iterator paid_files
+
+Iterates over the files the user has paid for.
+
+=cut
+
sub iter_paidfiles {
my ($self, $unused, $args) = @_;
return [ $user->paid_files ];
}
-sub admin_mode {
- return 0;
-}
-
sub tag_dynmove {
my ($self, $rindex, $rrdata, $url_prefix, $args, $acts, $templater) = @_;
return scalar @tiers;
}
-1;
+=back
-=head1 NAME
+=head2 Dynamic iterator filter syntax
+
+There a two types filters:
+
+=over
+
+=item * code filters - filters specified as perl code
+
+=item * tag filters - filtering on tags (articles only)
+
+=back
+
+=head3 Code filters
-BSE::Util::DynamicTags - basic dynamic page tags
+Specified as:
-=head1 REFERENCE
+=over
+
+C<< filter: I<perl code> >>
+
+=back
+
+The text C<ARTICLE> is replaced with the article being tested.
+
+The text C<<[I<column-name>]>> is replaced with that attribute of the
+article.
+
+=head3 Tag filters
+
+Should be a simple [] expression specifying the tags to filter on:
=over
-=item dthumbimage article geometry image field
+C<tags: [lcgi tags]>
-=item dthumbimage article geometry image
+=back
-Similar to thumbimage/gthumbimage, this allows you to retrieve images
-from a given article, which article can either be a number or a named
-article in the current context.
+=cut
-geometry and field are as for the static thumbimage tag.
+my $cols_re; # cache for below
-image is a comma separated list of match operators, eg:
+sub _get_filter {
+ my ($self, $state, $rargs, $acts, $templater) = @_;
- <:dthumbimage result search search,/^display_$/,1 :>
+ my %filter;
-on a search page will display either the image with an id of search,
-the first image found with an identifier starting with "display_" or
-the first image of the article.
+ if ($$rargs =~ s/tags:\s*(.*)\z//s) {
+ my $expr = $1;
+ my @match = $templater->get_parms($expr, $acts);
-Possible match operators are:
+ # always add the tags filter even if no tags were listed
+ # this means the other tag stuff continues to work
+ my @tags = grep length, map split('/'), @match;
+
+ $filter{tags} = \@tags;
+ }
+
+ if ($$rargs =~ s/filter:\s+(.*)\z//s) {
+ my $expr = $1;
+ my $orig_expr = $expr;
+ unless ($cols_re) {
+ require Articles;
+ my $cols_expr = '(' . join('|', Article->columns) . ')';
+ $cols_re = qr/\[$cols_expr\]/;
+ }
+ $expr =~ s/$cols_re/\$article->{$1}/g;
+ $expr =~ s/ARTICLE/\$article/g;
+ #print STDERR "Expr $expr\n";
+ my $filter;
+ $filter = eval 'sub { my $article = shift; '.$expr.'; }';
+ if ($@) {
+ print STDERR "** Failed to compile filter expression >>$expr<< built from >>$orig_expr<<\n";
+ return;
+ }
+
+ $filter{code} = $filter;
+ }
+
+ return \%filter;
+}
+
+sub _do_filter {
+ my ($self, $state, $filter, $articles) = @_;
+
+ $filter
+ or return $articles;
+
+ if (my $code = delete $filter->{code}) {
+ $articles = [ grep $code->($_), @$articles ];
+ }
+
+ if (my $tags = delete $filter->{tags}) {
+ my @out;
+ my %extras;
+
+ ARTICLE:
+ for my $art (@$articles) {
+ my %tags = map { $_ => 1 } $art->tags;
+ for my $tag (@$tags) {
+ $tags{$tag}
+ or next ARTICLE;
+ delete $tags{$tag};
+ }
+ push @out, $art;
+ ++$extras{$_} for keys %tags; # as long as they exist
+ }
+ $self->{tags}{$state->{plural}} = \%extras;
+
+ $articles = \@out;
+ }
+
+ return $articles;
+}
+
+my $paged_re =
+ qr(
+ \bpaged:
+ (?:(\w+)=)? # optional per page variable
+ ([0-9]+)? # optional per page default
+ (?:,(\w+))? # optional page selector
+ )x;
+
+sub _get_paged {
+ my ($self, $state, $rargs) = @_;
+
+ my $paged;
+ if ($$rargs =~ s/$paged_re//) {
+ $paged =
+ {
+ pp => $1 || "pp",
+ perpage => $2 || 20,
+ p => $3 || "p",
+ };
+ }
+
+ return $paged;
+}
+
+sub _do_paged {
+ my ($self, $state, $paged, $articles) = @_;
+
+ $state->{totalcount} = @$articles;
+
+ unless ($paged) {
+ $state->{page} = 1;
+ $state->{pagecount} = 1;
+ $state->{poffset} = 0;
+ $state->{perpage} = @$articles;
+ $state->{nextpage} = '';
+ $state->{prevpage} = '';
+ $state->{firstnumber} = 1;
+ $state->{lastnumber} = @$articles;
+ return $articles;
+ }
+
+ my ($page) = $self->cgi->param($paged->{p});
+ defined $page or $page = 1;
+ $page =~ /^[0-9]+$/ or $page = 1;
+ $page >= 1 or $page = 1;
+
+ my ($pp) = $self->cgi->param($paged->{pp});
+ defined $pp or $pp = $paged->{perpage};
+ $pp =~ /^[0-9]+$/ or $pp = 20;
+ $pp = int($pp);
+ $pp >= 1 or $pp = 20;
+ $state->{perpage} = $pp;
+
+ $state->{pagecount} = int((@$articles + $pp - 1) / $pp);
+ $state->{pagecount} == 0 and $state->{pagecount} = 1;
+ $page <= $state->{pagecount} or $page = $state->{pagecount};
+
+ $state->{page} = $page;
+ $state->{nextpage} = $page < $state->{pagecount} ? $page + 1 : '';
+ $state->{prevpage} = $page > 1 ? $page - 1 : '';
+ $state->{poffset} = ($page - 1) * $pp;
+ $state->{firstnumber} = 1 + $state->{poffset};
+ my $end = $state->{poffset} + $pp - 1;
+ $state->{lastnumber} = 1 + $end;
+ $end < @$articles or $end = $#$articles;
+
+ return [ @$articles[$state->{poffset} .. $end] ];
+}
+
+=head2 Common dynamic iterator tags
=over
=item *
-/regexp/ - a regular expression matched against the image identifier
+I<single> I<field> - access to the fields of the current item in the
+iteration.
=item *
-index - a numeric image index, where 1 is the first image
+I<single>C<_index> - the current index (zero-based) of the iteration.
=item *
-identifier - a literal image identifier
+I<single>C<_number> - the current number (one-based) of the iteration.
+
+=item *
+
+I<single>C<_count> I<...> - the number of items matched
+
+=item *
+
+C<if>I<Plural> I<...> - test if there are any items matched.
+
+=item *
+
+C<ifLast>I<Single> - test if this is the last item in the iteration.
+
+=item *
+
+C<ifFirst>I<Single> - test if this is the first item in the iteration.
+
+=item *
+
+C<next_>I<single> I<field> - retrieve values from the next item in the
+iteration.
+
+=item *
+
+C<previous_>I<single> I<field> - retrieve values from the previous
+item in the iteration.
+
+=item *
+
+C<ifNext>I<Single> - test if there is a next item in the iteration.
+
+=item *
+
+C<ifPrevious>I<Single> - test if there is a previous item in the
+iteration.
=back
-=item dgthumbimage geometry name field
+For article iterators only:
+
+=over
-=item dgthumbimage geometry name
+=item *
-Format a thumbnail for a global image, in dynamic context.
+C<move_>I<single> - in admin mode, a UI element to allow the article
+to be moved up/down one position.
=back
=cut
+
+sub _dyn_iterate_populate {
+ my ($self, $state, $args, $acts, $name, $templater) = @_;
+
+ my $method = "iter_$state->{plural}";
+ my $paged = $self->_get_paged($state, \$args);
+ local $self->{filter} = $self->_get_filter($state, \$args, $acts, $templater);
+ my $items = $self->_do_filter
+ ($state, $self->{filter}, $self->$method
+ ($state->{context}, $args, $acts, $templater, $state));
+
+ return $self->_do_paged($state, $paged, $items);
+}
+
+sub _dyn_iterate_reset {
+ my ($self, $state, $args, $acts, $name, $templater) = @_;
+
+ my $rindex = $state->{rindex};
+ my $rdata = $state->{rdata};
+ $$rdata = $self->_dyn_iterate_populate($state, $args, $acts, $name, $templater);
+ $$rindex = -1;
+
+ $state->{previous} = undef;
+ $state->{item} = undef;
+ if (@$$rdata) {
+ $state->{next} = $$rdata->[0];
+ }
+ else {
+ $state->{next} = undef;
+ }
+
+ 1;
+}
+
+sub _dyn_iterate {
+ my ($self, $state) = @_;
+
+ my $rindex = $state->{rindex};
+ my $rdata = $state->{rdata};
+ my $single = $state->{single};
+ if (++$$rindex < @$$rdata) {
+ $state->{previous} = $state->{item};
+ $state->{item} = $state->{next};
+ if ($$rindex < $#$$rdata) {
+ $state->{next} = $$rdata->[$$rindex+1];
+ }
+ else {
+ $state->{next} = undef;
+ }
+ $self->{req}->set_article("previous_$single" => $state->{previous});
+ $self->{req}->set_article($single => $state->{item});
+ $self->{req}->set_article("next_$single" => $state->{next});
+ $self->{current}{$state->{plural}} = $state->{item};
+ return 1;
+ }
+ else {
+ $self->{req}->set_article($single => undef);
+ $self->{current}{$state->{plural}} = undef;
+ return;
+ }
+}
+
+sub _dyn_item_low {
+ my ($self, $item, $args) = @_;
+
+ $item or return '';
+ my $value = $item->{$args};
+ defined $value
+ or return '';
+
+ return escape_html($value);
+}
+
+sub _dyn_item {
+ my ($self, $state, $args) = @_;
+
+ my $rindex = $state->{rindex};
+ my $rdata = $state->{rdata};
+ my $item = $state->{item};
+ unless ($state->{item}) {
+ return "** $state->{single} only usable inside iterator $state->{plural} **";
+ }
+
+ return $self->_dyn_item_low($item, $args);
+}
+
+sub _dyn_next {
+ my ($self, $state, $args) = @_;
+
+ return $self->_dyn_item_low($state->{next}, $args);
+}
+
+sub _dyn_previous {
+ my ($self, $state, $args) = @_;
+
+ return $self->_dyn_item_low($state->{previous}, $args);
+}
+
+sub _dyn_item_object_low {
+ my ($self, $item, $args, $state) = @_;
+
+ $item
+ or return '';
+ $item->can($args)
+ or return "* $args not valid for $state->{single} *";
+ my $value = $item->$args;
+ defined $value
+ or return '';
+
+ return escape_html($value);
+}
+
+sub _dyn_item_object {
+ my ($self, $state, $args) = @_;
+
+ unless ($state->{item}) {
+ return "** $state->{single} only usable inside iterator $state->{plural} **";
+ }
+
+ return $self->_dyn_item_object_low($state->{item}, $args, $state);
+}
+
+sub _dyn_next_obj {
+ my ($self, $state, $args) = @_;
+
+ return $self->_dyn_item_object_low($state->{next}, $args, $state);
+}
+
+sub _dyn_previous_obj {
+ my ($self, $state, $args) = @_;
+
+ return $self->_dyn_item_object_low($state->{previous}, $args, $state);
+}
+
+sub _dyn_ifNext {
+ my ($self, $state) = @_;
+
+ return defined $state->{next};
+}
+
+sub _dyn_ifPrevious {
+ my ($self, $state) = @_;
+
+ return defined $state->{previous};
+}
+
+sub _dyn_article {
+ my ($self, $state, $args) = @_;
+
+ my $rindex = $state->{rindex};
+ my $rdata = $state->{rdata};
+ unless ($state->{item}) {
+ return "** $state->{single} only usable inside iterator $state->{plural} **";
+ }
+
+ my $item = $state->{item}
+ or return '';
+
+ return tag_article($item, $self->{req}->cfg, $args);
+}
+
+sub _dyn_next_article {
+ my ($self, $state, $args) = @_;
+
+ $state->{next} or return '';
+
+ return tag_article($state->{next}, $self->{req}->cfg, $args);
+}
+
+sub _dyn_previous_article {
+ my ($self, $state, $args) = @_;
+
+ $state->{previous} or return '';
+
+ return tag_article($state->{previous}, $self->{req}->cfg, $args);
+}
+
+sub _dyn_index {
+ my ($self, $state) = @_;
+
+ my $rindex = $state->{rindex};
+ if ($$rindex < 0 || $$rindex >= @${$state->{rdata}}) {
+ return "** $state->{single} only valid inside iterator **";
+ }
+
+ return $state->{poffset} + $$rindex;
+}
+
+sub _dyn_number {
+ my ($self, $state) = @_;
+
+ my $rindex = $state->{rindex};
+ if ($$rindex < 0 || $$rindex >= @${$state->{rdata}}) {
+ return "** $state->{single} only valid inside iterator **";
+ }
+
+ return $state->{poffset} + 1 + $$rindex;
+}
+
+sub _dyn_count {
+ my ($self, $state, $args, $acts, $name, $templater) = @_;
+
+ my $data = $self->_dyn_iterate_populate($state, $args, $acts, $name, $templater);
+
+ return scalar @$data;
+}
+
+sub _dyn_if_first {
+ my ($self, $rindex, $rdata) = @_;
+
+ $$rindex == 0;
+}
+
+sub _dyn_if_last {
+ my ($self, $rindex, $rdata) = @_;
+
+ $$rindex == $#$$rdata;
+}
+
+sub dyn_iterator {
+ my ($self, $plural, $single, $context, $rindex, $rdata) = @_;
+
+ my $method = $plural;
+ my $index;
+ defined $rindex or $rindex = \$index;
+ my $data;
+ defined $rdata or $rdata = \$data;
+ my %state =
+ (
+ plural => $plural,
+ single => $single,
+ rindex => $rindex,
+ rdata => $rdata,
+ context => $context,
+ poffset => 0,
+ );
+ return
+ (
+ "iterate_${plural}_reset" =>
+ [ _dyn_iterate_reset => $self, \%state ],
+ "iterate_$plural" =>
+ [ _dyn_iterate => $self, \%state ],
+ $single =>
+ [ _dyn_item => $self, \%state ],
+ "${single}_index" =>
+ [ _dyn_index => $self, \%state ],
+ "${single}_number" =>
+ [ _dyn_number => $self, \%state ],
+ "${single}_count" =>
+ [ _dyn_count => $self, \%state ],
+ "if\u$plural" =>
+ [ _dyn_count => $self, \%state ],
+ "ifLast\u$single" => [ _dyn_if_last => $self, $rindex, $rdata ],
+ "ifFirst\u$single" => [ _dyn_if_first => $self, $rindex, $rdata ],
+ "next_$single" => [ _dyn_next => $self, \%state ],
+ "previous_$single" => [ _dyn_previous => $self, \%state ],
+ "ifNext\u$single" => [ _dyn_ifNext => $self, \%state ],
+ "ifPrevious\u$single" => [ _dyn_ifPrevious => $self, \%state ],
+ );
+}
+
+sub dyn_iterator_obj {
+ my ($self, $plural, $single, $context, $rindex, $rdata) = @_;
+
+ my $method = $plural;
+ my $index;
+ defined $rindex or $rindex = \$index;
+ my $data;
+ defined $rdata or $rdata = \$data;
+ my %state =
+ (
+ plural => $plural,
+ single => $single,
+ rindex => $rindex,
+ rdata => $rdata,
+ context => $context,
+ poffset => 0,
+ );
+ return
+ (
+ "iterate_${plural}_reset" =>
+ [ _dyn_iterate_reset => $self, \%state ],
+ "iterate_$plural" =>
+ [ _dyn_iterate => $self, \%state ],
+ $single =>
+ [ _dyn_item_object => $self, \%state ],
+ "${single}_index" =>
+ [ _dyn_index => $self, \%state ],
+ "${single}_number" =>
+ [ _dyn_number => $self, \%state ],
+ "${single}_count" =>
+ [ _dyn_count => $self, \%state ],
+ "if\u$plural" =>
+ [ _dyn_count => $self, \%state ],
+ "ifLast\u$single" => [ _dyn_if_last => $self, $rindex, $rdata ],
+ "ifFirst\u$single" => [ _dyn_if_first => $self, $rindex, $rdata ],
+ "next_$single" => [ _dyn_next_obj => $self, \%state ],
+ "previous_$single" => [ _dyn_previous_obj => $self, \%state ],
+ "ifNext\u$single" => [ _dyn_ifNext => $self, \%state ],
+ "ifPrevious\u$single" => [ _dyn_ifPrevious => $self, \%state ],
+ );
+}
+
+sub _dyn_article_move {
+ my ($self, $state, $args, $acts, $func, $templater) = @_;
+
+ $state->{parentid}
+ or return '';
+
+ return $self->tag_dynmove($state->{rindex}, $state->{rdata},
+ "stepparent=$state->{parentid}",
+ $args, $acts, $templater);
+}
+
+sub dyn_article_iterator {
+ my ($self, $plural, $single, $context, $rindex, $rdata) = @_;
+
+ my $method = $plural;
+ my $index;
+ defined $rindex or $rindex = \$index;
+ my $data;
+ defined $rdata or $rdata = \$data;
+ my %state =
+ (
+ plural => $plural,
+ single => $single,
+ rindex => $rindex,
+ rdata => $rdata,
+ context => $context,
+ poffset => 0,
+ );
+ $self->{context}{$plural} = $context;
+
+ require BSE::Util::Iterate;
+ my $it = BSE::Util::Iterate->new;
+ return
+ (
+ "iterate_${plural}_reset" =>
+ [ _dyn_iterate_reset => $self, \%state ],
+ "iterate_$plural" =>
+ [ _dyn_iterate => $self, \%state],
+ $single =>
+ [ _dyn_article => $self, \%state ],
+ "${single}_index" =>
+ [ _dyn_index => $self, \%state ],
+ "${single}_number" =>
+ [ _dyn_number => $self, \%state ],
+ "${single}_count" =>
+ [ _dyn_count => $self, \%state ],
+ "if\u$plural" =>
+ [ _dyn_count => $self, \%state ],
+ "ifLast\u$single" => [ _dyn_if_last => $self, $rindex, $rdata ],
+ "ifFirst\u$single" => [ _dyn_if_first => $self, $rindex, $rdata ],
+ "next_$single" => [ _dyn_next_article => $self, \%state ],
+ "previous_$single" => [ _dyn_previous_article => $self, \%state ],
+ "ifNext\u$single" => [ _dyn_ifNext => $self, \%state ],
+ "ifPrevious\u$single" => [ _dyn_ifPrevious => $self, \%state ],
+ "move_$single" => [ _dyn_article_move => $self, \%state ],
+ "${plural}_page" => [ _dyn_state => $self, \%state, "page" ],
+ "${plural}_perpage" => [ _dyn_state => $self, \%state, "perpage" ],
+ "${plural}_nextpage" => [ _dyn_state => $self, \%state, "nextpage" ],
+ "${plural}_prevpage" => [ _dyn_state => $self, \%state, "prevpage" ],
+ "${plural}_pagecount" => [ _dyn_state => $self, \%state, "pagecount" ],
+ "${single}_totalcount" => [ _dyn_state => $self, \%state, "totalcount" ],
+ "${plural}_firstnumber" => [ _dyn_state => $self, \%state, "firstnumber" ],
+ "${plural}_lastnumber" => [ _dyn_state => $self, \%state, "lastnumber" ],
+ $it->make
+ (
+ single => "${single}_pagec",
+ plural => "${plural}_pagec",
+ code => [ _dyn_iter_pages => $self, \%state ],
+ ),
+ );
+}
+
+sub _dyn_state {
+ my ($self, $state, $name) = @_;
+
+ return $state->{$name};
+}
+
+sub _dyn_iter_pages {
+ my ($self, $state) = @_;
+
+ my @pages;
+ for my $page (1 .. $state->{pagecount}) {
+ push @pages,
+ {
+ page => $page,
+ first => $page == 1,
+ last => $page == $state->{pagecount},
+ current => $page == $state->{page},
+ next => $page == $state->{pagecount} ? '' : $page+1,
+ prev => $page == 1 ? '' : $page-1,
+ };
+ }
+
+ return @pages;
+}
+
+sub get_cached {
+ my ($self, $id) = @_;
+
+ return $self->{_cache}{$id};
+}
+
+sub set_cached {
+ my ($self, $id, $value) = @_;
+
+ $self->{_cache}{$id} = $value;
+}
+
+sub _cart {
+ my ($self) = @_;
+
+ my $dyncart = $self->get_cached('cart');
+ $dyncart and return $dyncart;
+
+ my $cart = $self->{req}->session->{cart}
+ or return { cart => [], total_cost => 0, total_units => 0 };
+
+ my @cart;
+ my $total_cost = 0;
+ my $total_units = 0;
+ for my $item (@$cart) {
+ require Products;
+ my $product = Products->getByPkey($item->{productId});
+ my $extended = $product->price(user => scalar $self->{req}->siteuser)
+ * $item->{units};
+ my $link = $product->link;
+ $link =~ /^\w+:/
+ or $link = $self->{req}->cfg->entryErr('site', 'url') . $link;
+ push @cart,
+ {
+ ( map { $_ => $product->{$_} } $product->columns ),
+ %$item,
+ extended => $extended,
+ link => $link,
+ };
+ $total_cost += $extended;
+ $total_units += $item->{units};
+ }
+ my $result =
+ {
+ cart => \@cart,
+ total_cost => $total_cost,
+ total_units => $total_units,
+ };
+ $self->set_cached(cart => $result);
+
+ return $result;
+}
+
+1;
+
@ISA = qw(Exporter);
require Exporter;
-our $VERSION = "1.010";
+our $VERSION = "1.013";
sub _get_parms {
my ($acts, $args) = @_;
my @value = $cgi->param($_[0]);
escape_html("@value");
},
+ lcgi => [ tag_lcgi => $class, $cgi ],
+ deltag => [ tag_deltag => $class ],
+ ifTagIn => [ tag_ifTagIn => $class ],
old => [ \&tag_old, $cgi ],
oldi => [ \&tag_oldi, $cgi ],
$it->make_iterator(\&DevHelp::Tags::iter_get_repeat, 'repeat', 'repeats'),
);
}
+sub tag_lcgi {
+ my ($self, $cgi, $args) = @_;
+
+ $cgi or return '';
+ my $sep = "/";
+ if ($args =~ s/^\"([^\"\w]+)\"\s+//) {
+ $sep = $1;
+ }
+
+ return escape_html(join $sep, $cgi->param($args));
+}
+
+sub tag_deltag {
+ my ($self, $args, $acts, $func, $templater) = @_;
+
+ my $sep = "/";
+ if ($args =~ s/^\"([^\"\w]+)\"\s+//) {
+ $sep = $1;
+ }
+
+ require BSE::TB::Tags;
+ my ($del, @tags) = $templater->get_parms($args, $acts);
+ my $error;
+ my %del = map { BSE::TB::Tags->canon_name($_, \$error) => 1 }
+ split /\Q$sep/, $del;
+
+ return join $sep,
+ grep !$del{lc $_},
+ map BSE::TB::Tags->name($_, \$error),
+ map { split /\Q$sep/ }
+ @tags;
+}
+
+sub tag_ifTagIn {
+ my ($self, $args, $acts, $func, $templater) = @_;
+
+ my $sep = "/";
+ if ($args =~ s/^\"([^\"\w]+)\"\s+//) {
+ $sep = $1;
+ }
+
+ require BSE::TB::Tags;
+ my $error;
+ my ($check, @tags) = $templater->get_parms($args, $acts);
+ @tags = map BSE::TB::Tags->name($_, \$error),
+ map { split /\Q$sep/ }
+ @tags;
+
+ $check = BSE::TB::Tags->canon_name($check, \$error)
+ or return 0;
+
+ for my $tag (@tags) {
+ if (lc $tag eq $check) {
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
sub common {
my ($class, $req) = @_;
use strict;
use Carp qw(confess);
-our $VERSION = "1.003";
+our $VERSION = "1.004";
sub new {
my ($class, %opts) = @_;
my $perpage = ref $state{perpage_parm} ? ${$state{perpage_parm}} : $state{perpage_parm};
unless ($perpage =~ /^\d+$/) {
my ($name, $count) = $perpage =~ /^(\w+)=(\d+)$/
- or confess "Invalid perpage '$perpage'";
+ or confess "Invalid perpage_parm '$perpage'";
$name ||= 'pp';
$count ||= 10;
my $work = $state{cgi}->param($name);
use base 'BSE::ThumbLow';
use base 'BSE::TagFormats';
-our $VERSION = "1.002";
+our $VERSION = "1.003";
my $excerptSize = 300;
sub {
my ($name, $acts, $func, $templater) = @_;
my $item = $self->{admin_links} ? 'admin' : 'link';
- $acts->{$name} or return "<:url $name:>";
+ $acts->{$name}
+ or die "ENOIMPL\n";
my $url = $templater->perform($acts, $name, $item);
if (!$self->{admin} && $self->{admin_links}) {
$url .= $url =~ /\?/ ? "&" : "?";
id: bse/admin/edit/uplabelsect
description: label in parent list to make article a section
+id: bse/admin/edit/tags/
+description: System tags management
+
+id: bse/admin/edit/tags/saved
+description: flashed when a tag is renamed successfully. $1 - old name, $2 - new name
+
+id: bse/admin/edit/tags/removed
+description: flashed when a tag is removed successfully. $1 - tag name
+
+id: bse/admin/edit/tags/cleanup
+description: flashed after tags are cleaned up
+
+id: bse/admin/edit/tags/invalid_empty
+description: field error if the tag name is empty
+
+id: bse/admin/edit/tags/invalid_badchars
+description: field error if the tag name contains invalid characters
+
+id: bse/admin/edit/tags/bad_id
+description: tag_id field error if the tag id isn't present or isn't numeric
+
+id: bse/admin/edit/tags/unknown
+description: tag_id field error if the tag id supplied doesn't exist
+
+id: bse/admin/edit/tags/duplicate
+description: name field error if you try to rename a tag to match another
+
+id: bse/admin/edit/tags/nochange
+description: name field error if no change is saved
+
id: bse/admin/shop/
description: Shop Administration
id: bse/admin/edit/uplabelsect
message: -- move up a level -- become a section
+id: bse/admin/edit/tags/saved
+message: Tag renamed from '%1:s' to '%2:s'
+
+id: bse/admin/edit/tags/removed
+message: Tag '%1:s' removed.
+
+id: bse/admin/edit/tags/cleanup
+message: Deleted %1:d unused tags
+
+id: bse/admin/edit/tags/invalid_empty
+message: Tags must have a non-empty name
+
+id: bse/admin/edit/tags/invalid_badchars
+message: Tags cannot contain control characters, backslash (\) or forward slash (/)
+
+id: bse/admin/edit/tags/bad_id
+message: Invalid tag id
+
+id: bse/admin/edit/tags/unknown
+message: Unknown tag id
+
+id: bse/admin/edit/tags/duplicate
+message: There is already a tag with name '%1:s'
+
+id: bse/admin/edit/tags/nochange
+message: No changes to save
+
id: bse/admin/message/noid
message: Missing id parameter
--
-# VERSION=1.002
+# VERSION=1.003
name: bse_siteuserSeminarBookingsDetail
sql_statement: <<SQL
select ar.*, pr.*, se.*, ss.*, sb.*,
delete from bse_price_tier_prices
where product_id = ?
SQL
+
+name: TagMembers.removeByTag
+sql_statement: <<SQL
+delete from bse_tag_members
+where owner_type = ?
+ and owner_id = ?
+ and tag_id = ?
+SQL
+
+name: TagMembers.remove_owned_by
+sql_statement: <<SQL
+delete from bse_tag_members
+where owner_type = ?
+ and owner_id = ?
+SQL
+
+name: Tags.object_tags
+sql_statement: <<SQL
+select t.*
+from bse_tags t, bse_tag_members tm
+where t.id = tm.tag_id
+ and tm.owner_type = ?
+ and tm.owner_id = ?
+order by t.cat, t.val
+SQL
+
+name: Tag_ids.by_owner
+sql_statement: <<SQL
+select tag_id as "id"
+from bse_tag_members
+where owner_type = ?
+ and owner_id = ?
+SQL
+
+name: TagMembers.deleteTag
+sql_statement: <<SQL
+delete from bse_tag_members
+where tag_id = ?
+SQL
+
+name: Articles.byTag
+sql_statement: <<SQL
+select a.*
+from article a, bse_tag_members m
+where a.id = m.owner_id
+ and m.tag_id = ?
+SQL
+
+name: bseTagsCleanup
+sql_statement: <<SQL
+delete from bse_tags
+where id not in (select tag_id from bse_tag_members);
+SQL
/*border: 1px solid #44F;*/
}
+div.unusedtags {
+ padding-left: 1em;
+ padding-bottom: 0.5em;
+}
+
+div.pagelist {
+ padding: 2px 0px;
+}
+
+div.pagelist a,
+div.pagelist span {
+ padding: 2px 4px;
+}
+
+div.pagelist span {
+ background-color: #E8E8E9;
+}
+
+div.pagelist a {
+ background-color: #FFF0E0;
+}
+
+div.pagelist a:hover {
+ background-color: #FFE0C0;
+}
--- /dev/null
+Event.observe(document, "dom:loaded", function () {
+ var add = new Element("a", { href: "#" });
+ add.update("Add");
+ var add_div = new Element("div");
+ add_div.appendChild(add);
+
+ add.observe("click", function(add_div, ev) {
+ var new_tag = new Element("input", { type: "text", name: "tags" });
+ var new_div = new Element("div", { className: "tag" });
+ new_div.appendChild(new_tag);
+ var new_del = new Element("a", { href: "#" });
+ new_del.update("Delete");
+ new_del.observe("click", function(div, ev) {
+ new_div.remove();
+ ev.stop();
+ }.bind(this, new_div));
+ new_div.appendChild(new_del);
+ $("tags").insertBefore(new_div, add_div);
+ ev.stop();
+ }.bind(this, add_div));
+ $("tags").appendChild(add_div);
+ $$('#tags div.tag').each(function(div) {
+ var del = new Element("a", { href: "#" });
+ del.update("Delete");
+ div.appendChild(del);
+ del.observe("click", function(div, ev) {
+ div.remove();
+ ev.stop();
+ }.bind(this, div));
+ });
+});
<:ifMessage:>
<p><b><:message:></b></p>
<:or:><:eif:>
-<p>| <a href="/cgi-bin/admin/menu.pl">Admin menu</a> |
-<a href="<:script:>?id=-1&_t=img">Global Images</a> |
-<a href="<:script:>?id=-1&_t=file">Global Files</a> | </p>
-
+<:include admin/include/site_menu.tmpl:>
<:if Or [iadminuser_count] [iadmingroup_count]:>
<form action="/cgi-bin/admin/adminusers.pl">
<input type="hidden" name="id" value="<: article id:>" />
-<:wrap admin/base.tmpl title=>[cond [ifNew] [cat "New " [articleType]] [cat "Edit " [articleType] ": " [article title]]]:>
+<:wrap admin/base.tmpl title=>[cond [ifNew] [cat "New " [articleType]] [cat "Edit " [articleType] ": " [article title]]], js => "admin_edit.js":>
<h1><:ifNew:>New<:or:>Edit<:eif:> <:articleType:></h1>
<:if Message:>
<div id="message" <:ifError:>class="error"<:or:><:eif:>><:message:></div>
<:eif:>
<form enctype="multipart/form-data" method="post" action="<:script:>" name="edit">
- <input type="hidden" name="lastModified" value="<: old lastModified article lastModified :>" />
+ <input type="hidden" name="lastModified" value="<:article lastModified :>" />
<input type="hidden" name="type" value="Article" />
<input type="hidden" name="level" value="<: level :>" />
<input type="hidden" name="id" value="<: article id :>" />
</td>
<td class="help"><:help edit threshold:> <:error_img threshold:></td>
</tr>
- <tr>
- <th>Keywords:</th>
- <td>
- <:ifFieldPerm keyword:><input type="text" name="keyword" maxlength="255" size="60" value="<: old keyword default keyword :>" />
- (comma separated)<:or:><: article threshold :><:eif:></td>
- <td class="help"><:help edit keywords:> <:error_img keyword:></td>
- </tr>
- <tr>
- <th>Always Dynamic:</th>
- <td>
- <:ifFieldPerm force_dynamic:><input type="hidden" name="save_force_dynamic" value="1" /><input type="checkbox" name="force_dynamic" value="1" <:if Article force_dynamic :>checked="checked"<:or Article:><:eif Article:> />
- <:or:><:ifArticle force_dynamic :>Yes<:or Article:>No<:eif Article:><:eif:></td>
- <td class="help"><:help edit keywords:> <:error_img keyword:></td>
- </tr>
+<:include admin/include/edit_common.tmpl:>
<:include admin/article_custom.tmpl optional:>
<tr>
<th>Thumbnail image:</th>
-<:wrap admin/base.tmpl title => "Edit Catalog":>
+<:wrap admin/base.tmpl title => "Edit Catalog", js => "admin_edit.js":>
<h1>Edit Catalog:</h1>
<:ifMessage:>
<p><b><:message:></b></p>
</td>
<td class="help"><:help catalog threshold:> <:error_img threshold:></td>
</tr>
- <tr>
- <th> Keywords: </th>
- <td>
- <:ifFieldPerm keyword:><input type="text" name="keyword" maxlength="255" size="60" value="<: old keyword default keyword :>" /><:or:><: article threshold :><:eif:>
- (comma separated) </td>
- <td class="help"><:help catalog keywords:> <:error_img keyword:></td>
- </tr>
- <tr>
- <th>Always Dynamic:</th>
- <td>
- <:ifFieldPerm force_dynamic:><input type="hidden" name="save_force_dynamic" value="1" /><input type="checkbox" name="force_dynamic" value="1" <:if Article force_dynamic :>checked="checked"<:or Article:><:eif Article:> />
- <:or:><:ifArticle force_dynamic :>Yes<:or Article:>No<:eif Article:><:eif:></td>
- <td class="help"><:help edit keywords:> <:error_img keyword:></td>
- </tr>
+<:include admin/include/edit_common.tmpl:>
<:include admin/catalog_custom.tmpl optional:>
<tr>
<th>Thumbnail image:</th>
-<:wrap admin/base.tmpl title => [cond [ifNew] "Add Product" "Edit Product"], menuitem=>"edit", showtitle=>"1" :>
+<:wrap admin/base.tmpl title => [cond [ifNew] "Add Product" "Edit Product"], menuitem=>"edit", showtitle=>"1", js => "admin_edit.js" :>
<:ifMessage:>
<p><b><:message:></b></p>
<:or:><:eif:>
</td>
<td class="help"><:help product threshold:> <:error_img threshold:></td>
</tr>
- <tr>
- <th> Keywords: </th>
- <td>
- <:ifFieldPerm keyword:><input type="text" name="keyword" maxlength="255" size="60" value="<: old keyword default keyword :>" /><:or:><: article threshold :><:eif:>
- (comma separated) </td>
- <td class="help"><:help catalog keywords:> <:error_img keyword:></td>
- </tr>
- <tr>
- <th>Always Dynamic:</th>
- <td>
- <:ifFieldPerm force_dynamic:><input type="hidden" name="save_force_dynamic" value="1" /><input type="checkbox" name="force_dynamic" value="1" <:if Article force_dynamic :>checked="checked"<:or Article:><:eif Article:> />
- <:or:><:ifArticle force_dynamic :>Yes<:or Article:>No<:eif Article:><:eif:></td>
- <td class="help"><:help edit keywords:> <:error_img keyword:></td>
- </tr>
+<:include admin/include/edit_common.tmpl:>
<tr>
<th>Options:</th>
<td>
-<:wrap admin/base.tmpl title => "Edit Seminar":>
+<:wrap admin/base.tmpl title => "Edit Seminar", js => "admin_edit.js":>
<h1>Shop Administration</h1>
<:ifMessage:>
<p><b><:message:></b></p>
(<:alloptions:>)<:or:><:seminar options:><:eif:> </td>
<td class="help"><:help product options:> <:error_img options:></td>
</tr>
- <tr>
- <th> Keywords: </th>
- <td width="100%">
- <:ifFieldPerm keyword:><input type="text" name="keyword" maxlength="255" size="60" value="<: old keyword default keyword :>" /><:or:><: article threshold :><:eif:>
- (comma separated) </td>
- <td class="help"><:help catalog keywords:> <:error_img keyword:></td>
- </tr>
- <tr>
- <th>Always Dynamic:</th>
- <td width="100%">
- <:ifFieldPerm force_dynamic:><input type="hidden" name="save_force_dynamic" value="1" /><input type="checkbox" name="force_dynamic" value="1" <:if Article force_dynamic :>checked="checked"<:or Article:><:eif Article:> />
- <:or:><:ifArticle force_dynamic :>Yes<:or Article:>No<:eif Article:><:eif:></td>
- <td class="help"><:help edit keywords:> <:error_img keyword:></td>
- </tr>
+<:include admin/include/edit_common.tmpl:>
<:include admin/seminar_custom.tmpl optional:>
<tr>
<th>Thumbnail image:</th>
--- /dev/null
+ <tr>
+ <th>Keywords:</th>
+ <td>
+ <:ifFieldPerm keyword:><input type="text" name="keyword" maxlength="255" size="60" value="<: old keyword default keyword :>" />
+ (comma separated)<:or:><: article threshold :><:eif:></td>
+ <td class="help"><:help edit keywords:> <:error_img keyword:></td>
+ </tr>
+ <tr>
+ <th>Tags</th>
+ <td>
+ <input type="hidden" name="_save_tags" value="1" />
+ <div id="tags">
+ <:iterator begin tags:>
+ <div class="tag"><input type="text" name="tags" value="<:tag name:>" /></div>
+ <:iterator end tags:>
+ <div class="tag"><input type="text" name="tags" value="" /></div>
+ </div>
+ </td>
+ <td class="help"><:help edit tags:><:error_img tags:></td>
+ </tr>
+ <tr>
+ <th>Always Dynamic:</th>
+ <td>
+ <:ifFieldPerm force_dynamic:><input type="hidden" name="save_force_dynamic" value="1" /><input type="checkbox" name="force_dynamic" value="1" <:if Article force_dynamic :>checked="checked"<:or Article:><:eif Article:> />
+ <:or:><:ifArticle force_dynamic :>Yes<:or Article:>No<:eif Article:><:eif:></td>
+ <td class="help"><:help edit keywords:> <:error_img keyword:></td>
+ </tr>
--- /dev/null
+<p>| <a href="/cgi-bin/admin/menu.pl">Admin menu</a> |
+<a href="<:script:>?id=-1&_t=img">Global Images</a> |
+<a href="<:script:>?id=-1&_t=file">Global Files</a> |
+<a href="<:script:>?id=-1&a_tags=1">Tags</a> |
+</p>
--- /dev/null
+<:wrap admin/base.tmpl title => "System Article Tags", showtitle => 1 :>
+<:ifMessage:><p class="message"><:message:></p><:or:><:eif:>
+<:include admin/include/site_menu.tmpl:>
+<p>| <a href="<:script:>?id=-1&a_tags=1<:ifCgi showarts:><:or:>&showarts=1<:eif:>"><:ifCgi showarts:>Hide<:or:>Show<:eif:> articles for each tag</a> |
+<a href="<:script:>?id=-1&a_tagcleanup=1">Cleanup unused tags</a> |
+</p>
+<form action="<:script:>"><input type="hidden" name="id" value="-1" />Filter Category: <input type="text" name="cat" value="<:cgi cat:>" /> <label><input type="checkbox" name="nocat" <:ifCgi nocat:>checked="checked" <:or:><:eif:>/>Uncategorized only</label> <input type="submit" name="a_tags" value="Filter" /></form>
+<ul>
+<:iterator begin systags:>
+<li class="tag" id="tag_<:systag id:>"><form action="<:script:>#tag_<:systag id:>" method="post">
+<input type="hidden" name="id" value="-1" />
+<input type="hidden" name="tag_id" value="<:systag id:>" />
+<input type="text" name="name" value="<:ifAnd [cgi a_tagsave] [ifEq [cgi tag_id] [systag id]]:><:cgi name:><:or:><:systag name:><:eif:>" />
+<:ifEq [cgi tag_id] [systag id]:><:error_img name:><:or:><:eif:>
+<input type="submit" name="a_tagrename" value="Save" />
+<input type="submit" name="a_tagdelete" value="Delete" />
+</form>
+<:if Cgi showarts:>
+<:if Systagarts:>
+<ul>
+<:iterator begin systagarts:>
+<li><a href="<:script:>?id=<:systagart id:>"><:systagart title:></a></li>
+<:iterator end systagarts:>
+</ul>
+<:or Systagarts:>
+<p>No articles use this tag.</p>
+<:eif Systagarts:>
+<:or Cgi:><:eif Cgi:>
+</li>
+<:iterator end systags:>
+</ul>
--- /dev/null
+<:wrap base.tmpl:> <:embed start:><:admin:>
+<:ifDynamic:><:or:><p>I need to be dynamic</p><:eif:>
+<:iterator begin dynallprods tags:[lcgi tags] paged:pp=10 :><:iterator end dynallprods:>
+<p>Page count: <:dynallprods_pagecount:></p>
+<:if Eq [dynallprods_pagecount] 1:><:or Eq:>
+<div class="pagelist">Pages:
+ <:ifDynallprods_prevpage:><a href="<:url dynarticle:><:cond [ifMatch [url dynarticle] "\\?"] & ? :>p=<:dynallprods_prevpage:>&tags=<:lcgi tags |u:>&pp=<:dynallprods_perpage:>">< < Previous</a>
+ <:or:><span>< < Previous</span><:eif:>
+ <:ifDynallprods_nextpage:><a href="<:url dynarticle:><:cond [ifMatch [url dynarticle] "\\?"] & ? :>p=<:dynallprods_nextpage:>&tags=<:lcgi tags |u:>&pp=<:dynallprods_perpage:>">Next > ></a>
+ <:or:><span>Next > ></span><:eif:>
+<:iterator begin dynallprods_pagec:>
+ <:if Dynallprod_pagec current:>
+ <span><:dynallprod_pagec page:></span>
+ <:or Dynallprod_pagec:>
+ <a href="<:url dynarticle:><:cond [ifMatch [url dynarticle] "\\?"] & ? :>p=<:dynallprod_pagec page:>&tags=<:lcgi tags |u:>&pp=<:dynallprods_perpage:>"><:dynallprod_pagec page:></a>
+ <:eif Dynallprod_pagec:>
+<:iterator end dynallprods_pagec:>
+</div>
+<:eif Eq:>
+<:if Dyntags [lcgi tags]:>
+<p>Selected:
+<:iterator begin dyntags [lcgi tags] :>
+ <a href="<:url dynarticle:><:cond [ifMatch [url dynarticle] "\\?"] & ? :>p=<:dynallprods_page:>&tags=<:deltag [dyntag name] [lcgi tags] |u:>&pp=<:dynallprods_perpage:>"><:dyntag name:></a>
+<:iterator end dyntags:>
+</p>
+<:or Dyntags:><:eif Dyntags:>
+<:if Dynunused_tagcats dynallprods:>
+<div>Refine (<:dynallprod_totalcount:> products found):</div>
+<div class="unusedtags">
+<:iterator begin dynunused_tagcats dynallprods:>
+<div><:ifDynunused_tagcat nocat:><:or:><:dynunused_tagcat name:>:<:eif:>
+<:iterator begin dynunused_tags:><a href="<:url dynarticle:><:cond [ifMatch [url dynarticle] "\\?"] & ? :>p=<:dynallprods_page:>&tags=<:lcgi tags |u:>/<:dynunused_tag name |u:>&pp=<:dynallprods_perpage:>"><:dynunused_tag val:></a> <:iterator end dynunused_tags:></div>
+<:iterator end dynunused_tagcats:>
+</div>
+<:or Dynunused_tagcats:><:eif Dynunused_tagcats:>
+<:switch:><:case dynallprod_count tags:[lcgi tags] paged:pp=10 :>
+<form method="post" action="/cgi-bin/shop.pl">
+<input type="hidden" name="r" value="<:url dynarticle:><:cond [ifMatch [url dynarticle] "\\?"] & ? :>p=<:dynallprods_page:>&tags=<:lcgi tags |u:>&pp=<:dynallprods_perpage:>" />
+<div id="products">
+<:iterator begin dynallprods tags:[lcgi tags] paged:pp=10 :>
+<div class="product">
+<div><:dynallprod title:><span class="price">$<:money price dynallprod:></span></div>
+<a href="<:dyntarget shop add id [dynallprod id]:>&r=<:url dynarticle |U:><:cond [ifMatch [url dynarticle] "\?"] %26 %3F:>tags=<:lcgi tags|u:>%26p=<:dynallprods_page:>" class="add">Add to cart</a>
+<:dthumbimage dynallprod editor hero,1 :>
+</div>
+<:iterator end dynallprods:>
+</div>
+</form>
+<:case default:>
+<div>No matches</div>
+<:endswitch:>
+<:embed end:>
Column max_lapsed;int(11);NO;NULL;
Index PRIMARY;1;[subscription_id]
Index text_id;1;[text_id]
+Table bse_tag_members
+Engine MyISAM
+Column id;int(11);NO;NULL;auto_increment
+Column owner_type;char(2);NO;NULL;
+Column owner_id;int(11);NO;NULL;
+Column tag_id;int(11);NO;NULL;
+Index PRIMARY;1;[id]
+Index art_tag;1;[owner_id;tag_id]
+Index by_tag;0;[tag_id]
+Table bse_tags
+Engine MyISAM
+Column id;int(11);NO;NULL;auto_increment
+Column owner_type;char(2);NO;NULL;
+Column cat;varchar(80);NO;NULL;
+Column val;varchar(80);NO;NULL;
+Index PRIMARY;1;[id]
+Index cat_val;1;[owner_type;cat;val]
Table bse_user_subscribed
Engine MyISAM
Column subscription_id;int(11);NO;NULL;
qr!User\s+Logon!s);
}
fetch_ok($ua, "shop admin page", "$baseurl/cgi-bin/admin/shopadmin.pl",
- qr!Shop\s+administration!s);
+ qr!Shop\s+Administration!s);
fetch_ok($ua, "add article form", "$baseurl/cgi-bin/admin/add.pl",
qr!New\s+Page\sLev3!s);
fetch_ok($ua, "add catalog form", "$baseurl/cgi-bin/admin/add.pl?type=Catalog",
fetch_ok($ua, "group list", "$baseurl/cgi-bin/admin/adminusers.pl?a_groups=1",
qr!Admin\sGroups!s);
fetch_ok($ua, "subscriptions", "$baseurl/cgi-bin/admin/subs.pl",
- qr/Subscriptions\s+List/);
+ qr/Newsletter\s+List/);
fetch_ok($ua, "reports", "$baseurl/cgi-bin/admin/report.pl",
qr/Reports/);
# does a refresh unless the user is logged on
use BSE::Test qw(make_ua base_url);
use JSON;
use DevHelp::HTML;
-use Test::More tests => 193;
+use Test::More tests => 241;
+
+$| = 1;
my $ua = make_ua;
my $baseurl = base_url;
delete $data->{article}{$field};
}
is_deeply($data->{article}, \%temp, "check it matches what we saved");
+ ok($data->{article}{tags}, "has a tags member");
+ is_deeply($data->{article}{tags}, [], "which is an empty array ref");
}
my @fields = grep
}
}
+ my $tag_name1 = "YHUIOP";
+ my $tag_name2 = "zyx: alpha";
+ { # save tags
+ my %reqdata =
+ (
+ save => 1,
+ id => $art->{id},
+ _save_tags => 1,
+ tags => [ $tag_name2, " $tag_name1 " ],
+ lastModified => $art->{lastModified},
+ );
+ my $data = do_req($add_url, \%reqdata, "set tags");
+ SKIP:
+ {
+ $data or skip("Not json from setting tags", 2);
+ ok($data->{success}, "success flag set");
+ is_deeply($data->{article}{tags}, [ $tag_name1, $tag_name2 ],
+ "check tags saved");
+ $art = $data->{article};
+ }
+ }
+
{ # grab the tree
my %tree_req =
(
ok($art->{lastModified}, "entries have a lastModified");
}
+ { # grab the tags
+ my %tag_req =
+ (
+ a_tags => 1,
+ id => -1,
+ );
+ my $data = do_req($add_url, \%tag_req, "fetch tags");
+ SKIP:
+ {
+ $data or skip("not a json response", 4);
+ ok($data->{tags}, "it has tags");
+ my ($xyz_tag) = grep $_->{name} eq $tag_name2, @{$data->{tags}};
+ ok($xyz_tag, "check we found the tag we set");
+ is($xyz_tag->{cat}, "zyx", "check cat");
+ is($xyz_tag->{val}, "alpha", "check val");
+ }
+ }
+
+ my $tag1;
+ my $tag2;
+ { # grab them with article ids
+ my %tag_req =
+ (
+ a_tags => 1,
+ id => -1,
+ showarts => 1,
+ );
+ my $data = do_req($add_url, \%tag_req, "fetch tags");
+ SKIP:
+ {
+ $data or skip("not a json response", 6);
+ ok($data->{tags}, "it has tags");
+ ($tag1) = grep $_->{name} eq $tag_name1, @{$data->{tags}};
+ ($tag2) = grep $_->{name} eq $tag_name2, @{$data->{tags}};
+ ok($tag2, "check we found the tag we set");
+ is($tag2->{cat}, "zyx", "check cat");
+ is($tag2->{val}, "alpha", "check val");
+ ok($tag2->{articles}, "has articles");
+ ok(grep($_ == $art->{id}, @{$tag2->{articles}}),
+ "has our article id in it");
+ }
+ }
+
+ SKIP:
+ { # delete a tag globally
+ $tag2
+ or skip("didn't find the tag we want to remove", 6);
+ my %del_req =
+ (
+ a_tagdelete => 1,
+ id => -1,
+ tag_id => $tag2->{id},
+ );
+ my $data = do_req($add_url, \%del_req, "delete tag");
+ SKIP:
+ {
+ $data or skip("not a json response", 7);
+ ok($data->{success}, "successful");
+
+ # refetch tag list and make sure it's gone
+ my %get_req =
+ (
+ a_tags => 1,
+ id => -1,
+ );
+ my $tags_data = do_req($add_url, \%get_req, "refetch tags");
+ my ($tag) = grep $_->{name} eq $tag_name2, @{$data->{tags}};
+ ok(!$tag, "should be gone");
+
+ # try to delete it again
+ my $redel_data = do_req($add_url, \%del_req, "delete should fail");
+ $redel_data
+ or skip("not a json response", 3);
+ ok(!$redel_data->{success}, "should fail");
+ is($redel_data->{error_code}, "FIELD", "check error code");
+ ok($redel_data->{errors}{tag_id}, "and error message on field");
+ }
+ }
+
+ { # rename a tag
+ my %ren_req =
+ (
+ a_tagrename => 1,
+ id => -1,
+ tag_id => $tag1->{id},
+ name => $tag_name2, # rename over just removed tag
+ );
+
+ my $data = do_req($add_url, \%ren_req, "rename tag");
+ SKIP:
+ {
+ $data
+ or skip("not a json response", 4);
+ ok($data->{success}, "successful");
+ ok($data->{tag}, "returned updated tag");
+ is($data->{tag}{name}, $tag_name2, "check name saved");
+ }
+ }
+
+ { # refetch the article to check the tags
+ my %fetch_req =
+ (
+ a_article => 1,
+ id => $art->{id},
+ );
+ my $data = do_req($add_url, \%fetch_req, "fetch just saved")
+ or skip("no json", 2);
+ ok($data->{success}, "check success");
+ is_deeply($data->{article}{tags}, [ $tag_name2 ],
+ "check the tags");
+ }
+
# error handling on save
SKIP:
{ # bad title
}
}
+SKIP:
+{ # tag cleanup
+ my %clean_req =
+ (
+ a_tagcleanup => 1,
+ id => -1,
+ );
+ my $data = do_req($add_url, \%clean_req, "tag cleanup");
+ $data
+ or skip("no json response", 2);
+ ok($data->{success}, "successful");
+ ok($data->{count}, "should have cleaned up something");
+}
+
sub do_req {
my ($url, $req_data, $comment) = @_;
- my $content = join "&", map "$_=" . escape_uri($req_data->{$_}), keys %$req_data;
+ my @entries;
+ for my $key (keys %$req_data) {
+ my $value = $req_data->{$key};
+ if (ref $value) {
+ for my $val (@$value) {
+ push @entries, "$key=" . escape_uri($val);
+ }
+ }
+ else {
+ push @entries, "$key=" . escape_uri($value);
+ }
+ }
+ my $content = join("&", @entries);
+
+ print <<EOS;
+# Request:
+# URL: $add_url
+# Content: $content
+EOS
+
my $req = HTTP::Request->new(POST => $add_url, \@ajax_hdr);
$req->content($content);
-
+
my $resp = $ua->request($req);
ok($resp->is_success, "$comment successful at http level");
my $data = eval { from_json($resp->decoded_content) };
#!perl -w
use strict;
use BSE::Test ();
-use Test::More tests => 23;
+use Test::More tests => 83;
use File::Spec;
use FindBin;
my $cgidir = File::Spec->catdir(BSE::Test::base_dir, 'cgi-bin');
require BSE::API;
require BSE::Dynamic::Catalog;
require BSE::Request::Test;
-my $req = BSE::Request::Test->new(cfg => $cfg);
+
+$| = 1;
+
+my %cgi =
+ (
+ test1 => "one",
+ test2 => [ qw/two three/ ],
+ test3 => "Size: Medium",
+ test4 => [ "Size: Medium", "Colour: Red" ],
+ test5 => "Size:Medium/Colour:Red/Style:Pretty",
+ test6 => "/Size:Medium//Colour:Red/",
+ pp => 5,
+ p => 2,
+ );
+my $req = BSE::Request::Test->new(cfg => $cfg, params => \%cgi);
my $gen = BSE::Dynamic::Catalog->new($req);
BSE::API->import(qw/bse_make_catalog bse_make_product bse_add_step_child/);
ok($parent, "made a catalog");
is($parent->{generator}, "Generate::Catalog", "check generator");
+sleep 1;
my $parent2 = bse_make_catalog
(
cfg => $cfg,
# add some products
my @prods;
+my %prods;
my $price = 1000;
my %prod_order;
-for my $title (qw/prod1 prod2 prod3/) {
+for my $title (qw/prod1 prod2 prod3 prod4 prod5 prod6 prod7 prod8 prod9 prod10/) {
my $prod = bse_make_product
(
cfg => $cfg,
);
ok($prod, "make product $title/$prod->{id}");
unshift @prods, $prod;
+ $prods{$prod->title} = $prod;
$prod_order{$prod->{displayOrder}} = 1;
$price += 500;
}
display_order => $order++,
);
-is(scalar keys %prod_order, 3, "make sure display orders unique");
+is(scalar keys %prod_order, 10, "make sure display orders unique");
my $prod4 = bse_make_product
(
child => $parent2
);
+{
+ my %tags =
+ (
+ prod1 => [ "Size: Small", "Colour: Red", "ABC" ],
+ prod2 => [ "Size: Small", "Colour: Blue" ],
+ prod3 => [ "Size: Small", "Colour: Green", "ABC" ],
+ prod4 => [ "Size: Medium", "Colour: Red" ],
+ prod5 => [ "Size: Medium", "Colour: Blue", "Colour: Purple" ],
+ prod6 => [ "Size: Medium", "Colour: Green" ],
+ prod7 => [ "Size: Medium", "Colour: Black" ],
+ prod8 => [ "Size: Large", "Colour: Red" ],
+ prod9 => [ "Size: Large", "Colour: Blue" ],
+ prod10 => [ "Size: Large", "Colour: Green", "XYZ" ],
+ );
+ # set some tags
+ for my $key (sort keys %tags) {
+ my $error;
+ ok($prods{$key}->set_tags($tags{$key}, \$error),
+ "set tags on $key")
+ or print("# error: $error");
+
+ my @set = sort @{$tags{$key}};
+ my @tags = sort $prods{$key}->tags;
+ is_deeply(\@set, \@tags, "check tags set for $key");
+ }
+}
+
dyn_template_test "dynallprods", $parent, <<TEMPLATE, <<EXPECTED;
<:iterator begin dynallprods:><:
dynallprod id:><:ifDynAnyProductOptions:> options<:or:><:eif:>
$prods[0]{id}
$prods[1]{id}
$prods[2]{id} options
+$prods[3]{id}
+$prods[4]{id}
+$prods[5]{id}
+$prods[6]{id}
+$prods[7]{id}
+$prods[8]{id}
+$prods[9]{id}
+
+EXPECTED
+
+dyn_template_test "dynallprods tag filter", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallprods tags: "Size: Small" :><:
+dynallprod title:>
+<:iterator end dynallprods:>
+TEMPLATE
+prod3
+prod2
+prod1
+
+EXPECTED
+
+dyn_template_test "dynallprods tag filter cgi", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallprods tags: [lcgi test3] :><:
+dynallprod title:>
+<:iterator end dynallprods:>
+TEMPLATE
+prod7
+prod6
+prod5
+prod4
+
+EXPECTED
+
+dyn_template_test "dynallprods tag filter", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynunused_tagcats dynallprods tags: "Size: Small" :><:
+ifDynunused_tagcat nocat:><:or:><:
+dynunused_tagcat name:>:
+<:eif
+:><:iterator begin dynunused_tags:> <:dynunused_tag val:> (<:dynunused_tag count:>)
+<:iterator end dynunused_tags:><:iterator end dynunused_tagcats :>
+TEMPLATE
+ ABC (2)
+Colour:
+ Blue (1)
+ Green (1)
+ Red (1)
+
+EXPECTED
+
+dyn_template_test "unused tags no highlander", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynunused_tagcats dynallprods tags: "Colour: Blue" :><:
+ifDynunused_tagcat nocat:><:or:><:
+dynunused_tagcat name:>:
+<:eif
+:><:iterator begin dynunused_tags:> <:dynunused_tag val:> (<:dynunused_tag count:>)
+<:iterator end dynunused_tags:><:iterator end dynunused_tagcats :>
+TEMPLATE
+Colour:
+ Purple (1)
+Size:
+ Large (1)
+ Medium (1)
+ Small (1)
+
+EXPECTED
+
+dyn_template_test "unused tags highlander", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynunused_tagcats dynallprods onlyone tags: "Colour: Blue" :><:
+ifDynunused_tagcat nocat:><:or:><:
+dynunused_tagcat name:>:
+<:eif
+:><:iterator begin dynunused_tags:> <:dynunused_tag val:> (<:dynunused_tag count:>)
+<:iterator end dynunused_tags:><:iterator end dynunused_tagcats :>
+TEMPLATE
+Size:
+ Large (1)
+ Medium (1)
+ Small (1)
+
+EXPECTED
+
+dyn_template_test "dyntags", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dyntags "Size: Small/Colour: Red/XYZ" :><:
+dyntag name:>|<:dyntag cat:>|<:dyntag val:>|
+<:iterator end dyntags :>
+<:iterator begin dyntags [lcgi test5] :><:
+dyntag name:>|<:dyntag cat:>|<:dyntag val:>|
+<:iterator end dyntags :>
+<:iterator begin dyntags [lcgi test6] :><:
+dyntag name:>|<:dyntag cat:>|<:dyntag val:>|
+<:iterator end dyntags :>
+TEMPLATE
+Size: Small|Size|Small|
+Colour: Red|Colour|Red|
+XYZ||XYZ|
+
+Size: Medium|Size|Medium|
+Colour: Red|Colour|Red|
+Style: Pretty|Style|Pretty|
+
+Size: Medium|Size|Medium|
+Colour: Red|Colour|Red|
EXPECTED
$req->session->{cart} =
[
{
- productId => $prods[0]{id},
+ productId => $prods{prod3}{id},
units => 1,
- price => scalar $prods[0]->price(),
- title => scalar $prods[0]->title,
+ price => scalar $prods{prod3}->price(),
+ title => scalar $prods{prod3}->title,
}
];
Total: 20.00
EXPECTED
+dyn_template_test "cgi", $parent, <<TEMPLATE, <<EXPECTED;
+><:cgi unknown:><
+><:cgi test1:><
+><:cgi test2:><
+TEMPLATE
+><
+>one<
+>two three<
+EXPECTED
+
+dyn_template_test "lcgi", $parent, <<TEMPLATE, <<EXPECTED;
+><:lcgi unknown:><
+><:lcgi test1:><
+><:lcgi test2:><
+><:lcgi "," test1:><
+><:lcgi "," test2:><
+><:lcgi ")(" test2:><
+TEMPLATE
+><
+>one<
+>two/three<
+>one<
+>two,three<
+>two)(three<
+EXPECTED
+
+dyn_template_test "deltag", $parent, <<TEMPLATE, <<EXPECTED;
+><:deltag "Size: Medium" [lcgi test4]:><
+><:deltag "Size:Medium" [lcgi test4]:><
+><:deltag "Size:Medium/Colour:Red" [lcgi test5]:><
+><:deltag "Size:Medium" [lcgi test5]:><
+<:iterator begin dyntags [lcgi test5]
+:><:dyntag name:> - <:deltag [dyntag name] [lcgi test5]:>
+<:iterator end dyntags:>
+TEMPLATE
+>Colour: Red<
+>Colour: Red<
+>Style: Pretty<
+>Colour: Red/Style: Pretty<
+Size: Medium - Colour: Red/Style: Pretty
+Colour: Red - Size: Medium/Style: Pretty
+Style: Pretty - Size: Medium/Colour: Red
+
+EXPECTED
+
+dyn_template_test "ifTagIn", $parent, <<TEMPLATE, <<EXPECTED;
+<:ifTagIn "Size:medium" [lcgi test5]:>1<:or:>0<:eif:>
+<:ifTagIn "Size: Huge" [lcgi test5]:>1<:or:>0<:eif:>
+<:ifTagIn "Size: Medium" [lcgi test5]:>1<:or:>0<:eif:>
+<:ifTagIn "DEF" [lcgi test5]:>1<:or:>0<:eif:>
+TEMPLATE
+1
+0
+1
+0
+EXPECTED
+
+dyn_template_test "paged default", $parent, <<TEMPLATE, <<EXPECTED;
+<:iterator begin dynallprods paged: :><:iterator end dynallprods:>
+Current page: <:dynallprods_page:>
+Page count: <:dynallprods_pagecount:>
+Next page: <:dynallprods_nextpage:>
+Previous page: <:dynallprods_prevpage:>
+Total count: <:dynallprod_totalcount:>
+Count: <:dynallprod_count paged: :>
+First number this page: <:dynallprods_firstnumber:>
+Last number this page: <:dynallprods_lastnumber:>
+Perpage: <:dynallprods_perpage:>
+Pages: <:iterator begin dynallprods_pagec
+:><:dynallprod_pagec page
+:><:ifDynallprod_pagec current:>c<:or:><:eif
+:><:ifDynallprod_pagec first:>f<:or:><:eif
+:><:ifDynallprod_pagec last:>l<:or:><:eif
+:><:ifDynallprod_pagec next:>n<:dynallprod_pagec next:><:or:><:eif
+:><:ifDynallprod_pagec prev:>p<:dynallprod_pagec prev:><:or:><:eif:> <:iterator end dynallprods_pagec
+:>
+<:iterator begin dynallprods paged:
+:><:dynallprod_number:> <:dynallprod title:>
+<:iterator end dynallprods:>
+TEMPLATE
+
+Current page: 2
+Page count: 3
+Next page: 3
+Previous page: 1
+Total count: 11
+Count: 5
+First number this page: 6
+Last number this page: 10
+Perpage: 5
+Pages: 1fn2 2cn3p1 3lp2
+6 prod6
+7 prod5
+8 prod4
+9 prod3
+10 prod2
+
+EXPECTED
+
$prod4->remove($cfg);
for my $prod (@prods) {
$prod->remove($cfg);
$parent2->remove($cfg);
$parent->remove($cfg);
+# produces three test results
sub dyn_template_test($$$$) {
my ($tag, $article, $template, $expected) = @_;
projects / bse.git / commitdiff