0.15_16 commit r0_15_16
authorTony Cook <tony@develop-help.com>
Thu, 7 Jul 2005 03:18:25 +0000 (03:18 +0000)
committertony <tony@45cb6cf1-00bc-42d2-bb5a-07f51df49f94>
Thu, 7 Jul 2005 03:18:25 +0000 (03:18 +0000)
MANIFEST
Makefile
site/cgi-bin/admin/report.pl
site/cgi-bin/bse.cfg
site/cgi-bin/modules/BSE/Report.pm [new file with mode: 0644]
site/cgi-bin/modules/BSE/Util/Tags.pm
site/cgi-bin/modules/DevHelp/Report.pm
site/docs/bse.pod
site/templates/test/testrep.tmpl [new file with mode: 0644]
t/t20gen.t
test.cfg

index 16f2412..657bde8 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -74,6 +74,7 @@ site/cgi-bin/modules/BSE/Mail/SMTP.pm
 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
@@ -382,6 +383,7 @@ site/templates/shopitem.tmpl
 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
index a4c7f20..eb69404 100755 (executable)
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-VERSION=0.15_15
+VERSION=0.15_16
 DISTNAME=bse-$(VERSION)
 DISTBUILD=$(DISTNAME)
 DISTTAR=../$(DISTNAME).tar
index 1f4c7b0..33443f7 100755 (executable)
@@ -9,7 +9,7 @@ use BSE::Request;
 use BSE::Template;
 use BSE::Permissions;
 use BSE::Util::Tags;
-use DevHelp::Report;
+use BSE::Report;
 use DevHelp::HTML;
 use BSE::WebUtil 'refresh_to';
 
@@ -19,7 +19,7 @@ my $cgi = $req->cgi;
 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);
@@ -58,6 +58,9 @@ sub prompt {
   
   $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 '') {
@@ -93,6 +96,9 @@ sub show {
   $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);
index 7398f14..ceae45d 100644 (file)
@@ -256,6 +256,7 @@ yearly_sales=Yearly Sales
 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
@@ -304,6 +305,12 @@ type=sql
 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
diff --git a/site/cgi-bin/modules/BSE/Report.pm b/site/cgi-bin/modules/BSE/Report.pm
new file mode 100644 (file)
index 0000000..12df3b6
--- /dev/null
@@ -0,0 +1,58 @@
+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;
index 2ae05d7..9b5fdc4 100644 (file)
@@ -266,6 +266,7 @@ sub static {
      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 {
@@ -420,6 +421,7 @@ sub basic {
      $it->make_iterator(\&DevHelp::Tags::iter_get_repeat, 'repeat', 'repeats'),
      dynreplace => \&tag_replace,
      dyntoday => \&tag_today,
+     dynreport => \&tag_report,
     );
 }
 
@@ -802,5 +804,45 @@ sub tag_today {
   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;
 
index b6c5936..7f23037 100644 (file)
@@ -12,7 +12,23 @@ sub new {
 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 {
@@ -138,8 +154,22 @@ sub _load {
     ++$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 {
@@ -174,7 +204,6 @@ sub _get_type_html {
     my $method;
     if ($type_type) {
       $method = "_get_type_html_$type_type";
-      print STDERR "method $method\n";
       $type_type = undef unless $self->can($method);
     }
     
@@ -431,6 +460,7 @@ sub levels {
 
   my $report = $self->_load($repid, undef, $db);
   scalar @{$report->{sql}};
+  # scalar 1+@{$report->{breaks}};
 }
 
 sub show_template {
@@ -490,4 +520,106 @@ sub iter_levelN {
     } @$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;
index e6ff629..9e171f0 100644 (file)
@@ -10,6 +10,26 @@ Maybe I'll add some other bits here.
 
 =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
@@ -68,6 +88,17 @@ DevHelp::Date had been changed to try to import its import method from
 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.
diff --git a/site/templates/test/testrep.tmpl b/site/templates/test/testrep.tmpl
new file mode 100644 (file)
index 0000000..c07588a
--- /dev/null
@@ -0,0 +1,3 @@
+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
index 75b7f63..9c67aae 100644 (file)
@@ -1,7 +1,7 @@
 #!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');
@@ -226,6 +226,18 @@ TEMPLATE
 <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};
index 41477ec..fad912a 100644 (file)
--- a/test.cfg
+++ b/test.cfg
@@ -160,3 +160,5 @@ shop.cardprocessor=DevHelp::Payments::Test
 bse location validation.postcode_description=Funky Postcode
 
 seminar.locations=1
+
+#report total_sales.bse_rights=blah|edit_foo,blah