site/cgi-bin/modules/BSE/Mail/Sendmail.pm
site/cgi-bin/modules/BSE/Message.pm
site/cgi-bin/modules/BSE/Permissions.pm
+site/cgi-bin/modules/BSE/Report.pm
site/cgi-bin/modules/BSE/Request.pm
site/cgi-bin/modules/BSE/Session.pm
site/cgi-bin/modules/BSE/Shop/Util.pm
site/templates/sidebar/afflink.tmpl
site/templates/sidebar/logon.tmpl
site/templates/test/children.tmpl
+site/templates/test/testrep.tmpl
site/templates/textemail/basic.tmpl
site/templates/user/alreadyblacklisted_base.tmpl
site/templates/user/base_orderdetail.tmpl
-VERSION=0.15_15
+VERSION=0.15_16
DISTNAME=bse-$(VERSION)
DISTBUILD=$(DISTNAME)
DISTTAR=../$(DISTNAME).tar
use BSE::Template;
use BSE::Permissions;
use BSE::Util::Tags;
-use DevHelp::Report;
+use BSE::Report;
use DevHelp::HTML;
use BSE::WebUtil 'refresh_to';
BSE::Permissions->check_logon($req)
or do { refresh_to($req->url('logon'), $req->cfg); exit };
-my $reports = DevHelp::Report->new($req->cfg, 'reports');
+my $reports = BSE::Report->new($req);
if ($cgi->param('s_prompt') || $cgi->param('s_prompt.x')) {
prompt($req, $reports);
$reports->valid_report($repname)
or return list_reports($req, $reports, 'Invalid report id supplied');
+
+ $reports->report_accessible($repname)
+ or return list_reports($req, $reports, 'Report not accessible');
defined $msg or $msg = '';
if (keys %$errors && $msg eq '') {
$reports->valid_report($repname)
or return list_reports($req, $reports, 'Invalid report id supplied');
+ $reports->report_accessible($repname)
+ or return list_reports($req, $reports, 'Report not accessible');
+
my %errors;
my @params = $reports->validate_params($repname, $req->cgi,
BSE::DB->single, \%errors);
total_sales=Total Sales
users_vs_orders=Users vs Orders
user_products=Products bought by User
+bse_test=Test report
[report sales_summ_by_product]
sql1=select pr.articleId as "Id", ar.title as "Product", count(*) as "Units" from article ar, product pr, order_item oi where ar.id = pr.articleId and pr.articleId = oi.productId group by pr.articleId, ar.title
sql=select id, userId as "label" from site_users
novalues=[ There are no registered users ]
+[report bse_test]
+sql1=select id, title from article where id = ?
+hide=1
+param1=article,Article
+sql1params=1
+
[valid child types]
Article=Article
Catalog=Catalog,Product
--- /dev/null
+package BSE::Report;
+use strict;
+
+use base 'DevHelp::Report';
+
+sub new {
+ my ($class, $req_or_cfg) = @_;
+
+ my ($cfg, $req);
+ if ($req_or_cfg->isa('BSE::Cfg')) {
+ $cfg = $req_or_cfg;
+ }
+ else {
+ $cfg = $req_or_cfg->cfg;
+ $req = $req_or_cfg;
+ }
+
+ my $work = $class->SUPER::new($cfg, 'reports');
+ $req and $work->{req} = $req;
+
+ return $work;
+}
+
+sub list_reports {
+ my ($self) = @_;
+
+ if ($self->{req}) {
+ my %entries = $self->SUPER::list_reports;
+ my @delete;
+ for my $key (keys %entries) {
+ $self->report_accessible($key) or push @delete, $key;
+ }
+ delete @entries{@delete};
+ return %entries;
+ }
+ else {
+ return;
+ }
+}
+
+sub report_accessible {
+ my ($self, $report) = @_;
+
+ $self->{req} or return;
+
+ my $rights = $self->report_entry($report, 'bse_rights');
+ defined $rights or $rights = '';
+ $rights =~ tr/ //d;
+ $rights eq '' and return 1; # no controls
+ for my $set (split /\|/, $rights) {
+ grep $self->{req}->user_can($_, -1), split /[,;]/, $set
+ and return 1;
+ }
+
+ return;
+}
+
+1;
adminbase => [ \&tag_adminbase, $cfg ],
help => [ \&tag_help, $cfg, 'user' ],
$it->make_iterator(\&DevHelp::Tags::iter_get_repeat, 'strepeat', 'strepeats'),
+ report => [ \&tag_report, $cfg ],
_format =>
sub {
$it->make_iterator(\&DevHelp::Tags::iter_get_repeat, 'repeat', 'repeats'),
dynreplace => \&tag_replace,
dyntoday => \&tag_today,
+ dynreport => \&tag_report,
);
}
return POSIX::strftime($args, localtime);
}
+sub tag_report {
+ my ($cfg, $args, $acts, $tag_name, $templater) = @_;
+
+ my ($rep_name, $template, @args) =
+ DevHelp::Tags->get_parms($args, $acts, $templater);
+ defined $rep_name
+ or return "** no report name supplied to $tag_name tag **";
+
+ require BSE::Report;
+ my $reports = BSE::Report->new($cfg);
+ my $report = $reports->load($rep_name, undef, BSE::DB->single);
+ $report
+ or return "** could not load report $rep_name **";
+
+ # this will get embedded and normal tag replacement will then
+ # operate on it, no need to include basic/static tags
+ my %acts;
+ my $msg;
+ %acts =
+ (
+ %$acts,
+ $reports->show_tags($rep_name, BSE::DB->single, \$msg, @args),
+ );
+
+ $msg
+ and return "** error in $tag_name: $msg **";
+
+ if (!defined $template or $template eq '-') {
+ $template = $reports->show_template($rep_name) || 'admin/reports/show';
+ }
+
+ my $html = BSE::Template->get_source($template, $cfg);
+ if ($html =~ /<:\s*embed\s*start\s*:>(.*)<:\s*embed\s*end\s*:>/s
+ || $html =~ m"<\s*body[^>]*>(.*)<\s*/\s*body>"s) {
+ $html = $1;
+ }
+
+ return BSE::Template->replace($html, $cfg, \%acts);
+}
+
1;
sub list_reports {
my ($self) = @_;
- $self->{cfg}->entries($self->{section});
+ # we don't list reports with hide set
+ my %entries = $self->{cfg}->entries($self->{section});
+ my @delete;
+ # deleting while iterating is bad
+ for my $key (keys %entries) {
+ push @delete, $key
+ if $self->{cfg}->entry("report $key", "hide");
+ }
+ delete @entries{@delete};
+
+ %entries;
+}
+
+sub report_entry {
+ my ($self, $reportid, $entrykey) = @_;
+
+ $self->{cfg}->entry("report $reportid", $entrykey);
}
sub list_tags {
++$sql_index;
}
$report{sql} = \@sql;
+
+ my @breaks;
+ my $break_index = 1;
+ while (my $breaks = $cfg->entry($repsect, "break$break_index")) {
+ push @breaks, [ grep $_, split /[,;]/, lc $breaks ];
+ ++$break_index;
+ }
+ $report{breaks} = \@breaks;
+
+ @{$report{sql}} or return;
- \%report;
+ bless \%report, 'DevHelp::Report::Report';
+}
+
+sub load {
+ goto &_load;
}
sub prompt_template {
my $method;
if ($type_type) {
$method = "_get_type_html_$type_type";
- print STDERR "method $method\n";
$type_type = undef unless $self->can($method);
}
my $report = $self->_load($repid, undef, $db);
scalar @{$report->{sql}};
+ # scalar 1+@{$report->{breaks}};
}
sub show_template {
} @$source;
}
+# sub show_tags {
+# my ($self, $repid, $db, $rmsg, @params) = @_;
+
+# # build up result sets
+# my $dbh = $db->dbh;
+# my $report = $self->_load($repid, undef, $db);
+# my @results;
+# for my $sql (@{$report->{sql}}) {
+# my %result;
+# my $sth = $dbh->prepare($sql->{sql});
+# unless ($sth) {
+# $$rmsg = "Error preparing $sql->{sql}: ".$dbh->errstr;
+# return;
+# }
+# my @sqlp = @params[ map $_-1, @{$sql->{params}} ];
+# unless ($sth->execute(@sqlp)) {
+# $$rmsg = "Error executing $sql->{sql}: ".$dbh->errstr;
+# return;
+# }
+# my @names_lc = @{$sth->{NAME_lc}};
+# $result{names} = \@names_lc;
+# $result{names_hash} =
+# map { $names_lc[$_] => $_ } 0 .. $#names_lc;
+# $result{titles} = [ @{$sth->{NAME}} ];
+# my @rows;
+# while (my $row = $sth->fetchrow_arrayref) {
+# push @rows, [ @$row ];
+# }
+# $result{rows} = \@rows;
+
+# push @results, \%result;
+# }
+
+# # make sure all breaks are in all the sources
+# my %missing_breaks;
+# my $sql_index = 1;
+# for my $result (@results) {
+# for my $break_col (map @$_, @{$report->{breaks}}) {
+# unless (exists $results->{names_hash}{$break_col}) {
+# print STDERR "Missing break column $break_col from sql$sql_index\n";
+# ++$missing_breaks{$break_col};
+# }
+# }
+# ++$sql_index;
+# }
+
+# # go through and remove any break levels with missing break columns
+# my @breaks;
+# for my $break ($report->{breaks}) {
+# my @work_breaks = grep !$missing_breaks{$_}, @$break;
+# push @breaks, \@work_breaks if @work_breaks;
+# }
+# my @allbreaks = map @$_, @breaks;
+
+# # split into bottom level control breaks
+# my @levels;
+# if (@allbreaks) {
+# # split out level 0
+# my %allsegs;
+# my @splitresults;
+# for my $result (@results) {
+# my %split;
+# my @cols = map $result->{names_hash}{$_}, @allbreaks;
+# for my $row (@{$result->{rows}}) {
+# my $key = join "\0", @$row{@cols};
+# ++$allsegs{$key};
+# push @{$split{$key}}, $row;
+# }
+# push @splitresults, \%split;
+# }
+# push @levels, \@splitresults;
+
+# # make up the other levels
+# # first break out the levels by depth
+# my @breaklevels;
+# my @workbreaks;
+# for my $break (@{$report->{breaks}}) {
+# push @workbreaks, @$break;
+# unshift @breaklevels, [ @workbreaks ];
+# }
+# shift @breaklevels; # don't need the last one
+
+# for my $break (@breaklevels) {
+# my %split;
+# my @cols = @$break;
+
+# }
+# }
+# else {
+# push @levels,
+# [
+# map +{ '' => $_->{rows} }, @results;
+# ];
+# }
+# }
+
+package DevHelp::Report::Report;
+
+sub param_count {
+ scalar @{$_[0]{params}};
+}
+
1;
=head1 CHANGES
+=head2 0.15_16
+
+Adds the report changes except for control-break reports.
+
+I'm going to workaround control-break reports for now, it was taking
+way too long. I'll implement them at a future date when there's no
+time pressure.
+
+=over
+
+=item *
+
+implemented the <:report ...:> and <:dynreport ...:> tags
+
+=item *
+
+added access controls to reports
+
+=back
+
=head2 0.15_15
=over
Exporter, but this doesn't work on older perls. Reverted to subclass
Exporter.
+=item *
+
+upgrade_mysql.pl wasn't correctly checking the entered number, and
+would perform the upgrade even if the incorrect value was entered.
+
+=item *
+
+upgrade_mysql.pl now treats C< varchar(...) binary > as if it were C<
+varbinary(...) > and no longer treats this as a column type change
+(unless the size changes)
+
=back
This is a development release, not intended for production.
--- /dev/null
+Report: <:report name:>
+<:iterator begin level1_names:><:level1_name name:><:iterator separator level1_names:> <:iterator end level1_names:>
+<:iterator begin level1:><:iterator begin level1_cols:><:level1_col value:><:iterator separator level1_cols:> <:iterator end level1_cols:><:iterator end level1:>
\ No newline at end of file
#!perl -w
use strict;
use BSE::Test ();
-use Test::More tests=>67;
+use Test::More tests=>70;
use File::Spec;
use FindBin;
my $cgidir = File::Spec->catdir(BSE::Test::base_dir, 'cgi-bin');
<meta name="DC.format" content="text/html" />
EXPECTED
+template_test "report", $parent, <<'TEMPLATE', <<EXPECTED;
+<:report bse_test test/testrep 2:>
+<:report bse_test test/testrep [article id]:>
+TEMPLATE
+Report: Test report
+id title
+2 [index subsection]
+Report: Test report
+id title
+$parent->{id} Parent
+EXPECTED
+
BSE::Admin::StepParents->del($parent, $parent);
for my $kid (reverse @kids) {
my $name = $kid->{title};
bse location validation.postcode_description=Funky Postcode
seminar.locations=1
+
+#report total_sales.bse_rights=blah|edit_foo,blah
projects / bse.git / commitdiff