0.15_18 commit r0_15_18
authorTony Cook <tony@develop-help.com>
Thu, 14 Jul 2005 06:46:42 +0000 (06:46 +0000)
committertony <tony@45cb6cf1-00bc-42d2-bb5a-07f51df49f94>
Thu, 14 Jul 2005 06:46:42 +0000 (06:46 +0000)
12 files changed:
MANIFEST
Makefile
site/cgi-bin/bse.cfg
site/cgi-bin/modules/BSE/Cfg.pm
site/cgi-bin/modules/BSE/UI/Dispatch.pm
site/cgi-bin/modules/BSE/Util/Tags.pm
site/cgi-bin/modules/DevHelp/LoaderData.pm [new file with mode: 0644]
site/cgi-bin/modules/DevHelp/Report.pm
site/cgi-bin/modules/DevHelp/Tags.pm
site/cgi-bin/modules/DevHelp/Validate.pm
site/docs/bse.pod
site/util/loaddata.pl [new file with mode: 0644]

index cd9f402..e19f81b 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -133,6 +133,7 @@ site/cgi-bin/modules/DevHelp/DynSort.pm
 site/cgi-bin/modules/DevHelp/FileUpload.pm
 site/cgi-bin/modules/DevHelp/Formatter.pm
 site/cgi-bin/modules/DevHelp/HTML.pm
+site/cgi-bin/modules/DevHelp/LoaderData.pm
 site/cgi-bin/modules/DevHelp/Payments/Inpho.pm
 site/cgi-bin/modules/DevHelp/Payments/Test.pm
 site/cgi-bin/modules/DevHelp/Report.pm
@@ -417,6 +418,7 @@ site/templates/user/userpage_base.tmpl
 site/templates/xbase.tmpl
 site/util/gen.pl
 site/util/initial.pl
+site/util/loaddata.pl
 site/util/mysql.str
 site/util/upgrade_mysql.pl
 t/BSE/Test.pm
index e6e75ae..8f83df0 100755 (executable)
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-VERSION=0.15_17
+VERSION=0.15_18
 DISTNAME=bse-$(VERSION)
 DISTBUILD=$(DISTNAME)
 DISTTAR=../$(DISTNAME).tar
index ceae45d..dafad35 100644 (file)
@@ -175,7 +175,7 @@ articles=not(3)
 [permission full_access]
 brief=Full access (Site)
 help=Full access to the article.  The user can modify all modifiable fields, delete and add articles at will.
-permissions=edit_*,regen_*
+permissions=edit_*,regen_*,bse_*
 descendants=1
 articles=-1
 
index fe22bc9..aeb2ac1 100644 (file)
@@ -301,10 +301,16 @@ sub _load_cfg {
     }
     elsif (/^\s*([^=\s]+)\s*=\s*(.*)$/) {
       $section or next;
-      push @{$sections{$section}{order}}, lc $1;
-      $sections{$section}{values}{lc $1} = $2;
-      push @{$sections{$section}{order_nc}}, $1;
-      $sections{$section}{case}{$1} = $2;
+      my ($key, $value) = ($1, $2);
+      if ($value =~ /^<<(\w+)$/) {
+       $value = _get_heredoc(\*CFG, $file, $1);
+       defined $value
+         or last;
+      }
+      push @{$sections{$section}{order}}, lc $key;
+      $sections{$section}{values}{lc $key} = $value;
+      push @{$sections{$section}{order_nc}}, $key;
+      $sections{$section}{case}{$key} = $value;
     }
   }
   close CFG;
@@ -350,10 +356,16 @@ sub _load_cfg {
        }
        elsif (/^\s*([^=\s]+)\s*=\s*(.*)$/) {
          $section or next;
-         push @{$sections{$section}{order}}, lc $1;
-         $sections{$section}{values}{lc $1} = $2;
-         push @{$sections{$section}{order_nc}}, $1;
-         $sections{$section}{case}{$1} = $2;
+         my ($key, $value) = ($1, $2);
+         if ($value =~ /^<<(\w+)$/) {
+           $value = _get_heredoc(\*CFG, $file, $1);
+           defined $value
+             or last;
+         }
+         push @{$sections{$section}{order}}, lc $key;
+         $sections{$section}{values}{lc $key} = $value;
+         push @{$sections{$section}{order_nc}}, $key;
+         $sections{$section}{case}{$key} = $value;
        }
       }
       close CFG;
@@ -372,6 +384,31 @@ sub _load_cfg {
   return $self;
 }
 
+=item _get_heredoc($fh, $end_marker)
+
+Read in a heredoc.
+
+Strips the last newline.
+
+=cut
+
+sub _get_heredoc {
+  my ($fh, $filename, $end_marker) = @_;
+  
+  my $start = $.; # to report it later
+  my $value = '';
+  while (my $line = <$fh>) {
+    chomp(my $test = $line);
+    if ($test eq $end_marker) {
+      chomp $value;
+      return $value;
+    }
+    $value .= $line;
+  }
+
+  print STDERR "No end to here-doc started line $start of $filename\n";
+}
+
 =item _error($msg)
 
 Error handling for entryErr().  Saves the message and dies.
index 7b61772..8113e03 100644 (file)
@@ -61,4 +61,25 @@ sub action_prefix {
   'a_';
 }
 
+# returns a result of an error page
+sub error {
+  my ($class, $req, $errors, $template) = @_;
+
+  my $msg = $req->message($errors);
+
+  $template ||= 'error';
+
+  require BSE::Util::Tags;
+  my %acts;
+  %acts =
+    (
+     BSE::Util::Tags->basic(\%acts, $req->cgi. $req->cfg),
+     error_img => [ \&tag_error_img, $req->cfg, $errors ],
+     msg => $msg,
+     error => $msg, # so we can use the original error.tmpl
+    );
+
+  return $req->response($template, \%acts);
+}
+
 1;
index 9b5fdc4..1a9fb3f 100644 (file)
@@ -421,7 +421,7 @@ sub basic {
      $it->make_iterator(\&DevHelp::Tags::iter_get_repeat, 'repeat', 'repeats'),
      dynreplace => \&tag_replace,
      dyntoday => \&tag_today,
-     dynreport => \&tag_report,
+     dynreport => [ \&tag_report, $cfg ],
     );
 }
 
diff --git a/site/cgi-bin/modules/DevHelp/LoaderData.pm b/site/cgi-bin/modules/DevHelp/LoaderData.pm
new file mode 100644 (file)
index 0000000..100e509
--- /dev/null
@@ -0,0 +1,235 @@
+package DevHelp::LoaderData;
+use strict;
+use Carp 'confess';
+
+sub new {
+  my ($class, $file, %opts) = @_;
+  
+  my $intro = <$file>;
+  chomp $intro;
+  my $result;
+  if ($intro eq '--') {
+    $result = DevHelp::LoaderData::Fields->new($file);
+  } 
+  elsif ($intro =~ /\t/) {
+    $result = DevHelp::LoaderData::Tab->new($file, $intro);
+  }
+  else {
+    $result = DevHelp::LoaderData::CSV->new($file, $intro);
+  }
+  $result->_set_opts(%opts);
+
+  $result;
+}
+
+sub _readline {
+  my ($self) = @_;
+
+  $self->{eof} and return;
+
+  my $file = $self->{file};
+
+  my $line = <$file>;
+  unless (defined $line) {
+    ++$self->{eof};
+    return;
+  }
+  chomp $line;
+  while ($line =~ /\\$/) {
+    chop $line;
+    my $next = <$file>;
+    unless (defined $next) {
+      ++$self->{eof};
+      last;
+    }
+    $line .= $next;
+    chomp $line;
+  }
+
+  #print "_readline: $line\n";
+  $line;
+}
+
+sub _untabify {
+  my ($value) = @_;
+
+  while ((my $pos = index($value, "\t")) >= 0) {
+    substr($value, $pos, 1) = " " x (8 - $pos % 8);
+  }
+
+  $value;
+}
+
+my %escapes =
+  (
+   n => "\n",
+   t => "\t",
+   r => "\r",
+   '"' => '"',
+   "'" => "'",
+   ' ' => ' ',
+   "\n" => '',
+   "\\" => "\\",
+  );
+
+sub _unescape_code {
+  my ($code) = @_;
+
+  if (exists $escapes{$code}) {
+    return $escapes{$code};
+  }
+  elsif ($code =~ /^\d+$/) {
+    return chr(oct($code));
+  }
+  elsif ($code =~ /^x/) {
+    return chr(oct("0$code"));
+  }
+  else {
+    confess "Internal error: cannot convert $code";
+  }
+}
+
+sub _unescape {
+  my ($self, $value) = @_;
+
+  $value =~ s/\\([0-7]{1,3}|x[\da-fA-F][\da-fA-F]|[ntr \"\'\n\\])/
+    _unescape_code($1)/eg;
+
+  $value;
+}
+
+sub _read_heredoc {
+  my ($self, $word) = @_;
+
+  my $file = $self->{file};
+  my @lines;
+  my $start = $.;
+  while (defined(my $line = <$file>)) {
+    $line = _untabify($line);
+    if ($line =~ /^( *)$word\n?$/) {
+      my $indent = $1;
+      my $pos = 0;
+      for my $work (@lines) {
+        unless ($work =~ s/^$indent//) {
+          warn "Line $. doesn't match terminator indent\n";
+        }
+        ++$pos;
+      }
+      return join '', @lines;
+    }
+    push @lines, $self->_unescape($line);
+  }
+  die "Could not find end of '$word' heredoc started on line $start\n";
+}
+
+sub _set_opts {
+  my ($self, %opts) = @_;
+
+  if (exists $opts{noheredoc}) {
+    $self->{noheredoc} = $opts{noheredoc};
+  }
+}
+
+package DevHelp::LoaderData::Fields;
+use vars qw(@ISA);
+@ISA = qw(DevHelp::LoaderData);
+
+sub new {
+  my ($class, $file) = @_;
+
+  return bless { file => $file }, $class;
+}
+
+sub read {
+  my ($self) = @_;
+
+  my %data;
+  while (my $line = $self->_readline) {
+    $line =~ /\S/ or last;
+    $line =~ /^\s*#/ and next;
+    my ($name, $value) = split /:\s?/, $line, 2;
+    if ($value =~ /^<<(\w+)$/) {
+      $value = $self->_read_heredoc($1);
+    }
+    else {
+      $value = $self->_unescape($value);
+    }
+    $data{$name} = $value;
+  }
+
+  keys %data or return;
+
+  return \%data;
+}
+
+package DevHelp::LoaderData::CSV;
+use vars qw(@ISA);
+@ISA = qw(DevHelp::LoaderData::Delimited);
+
+sub new {
+  my ($class, $file, $intro) = @_;
+
+  my @fields = split /,/, $intro;
+
+  @fields or confess("Invalid intro $intro\n");
+
+  return bless { file => $file, fields=>\@fields, sep => "," }, $class;
+}
+
+package DevHelp::LoaderData::Tab;
+use vars qw(@ISA);
+@ISA = qw(DevHelp::LoaderData::Delimited);
+
+sub new {
+  my ($class, $file, $intro) = @_;
+
+  my @fields = split /\t/, $intro;
+
+  @fields or confess("Invalid intro $intro\n");
+
+  return bless { file => $file, fields=>\@fields, sep => "\t" }, $class;
+}
+
+package DevHelp::LoaderData::Delimited;
+use vars qw(@ISA);
+@ISA = qw(DevHelp::LoaderData);
+
+sub read {
+  my ($self) = @_;
+
+  my %data;
+  my $index = 0;
+  my $line = $self->_readline;
+  while (defined $line && $line =~ /^\s*\#/) {
+    $line = $self->_readline;
+  }
+  my $sep = $self->{sep};
+  defined $line or return;
+  while ($line ne '') {
+    if ($index >= @{$self->{fields}}) {
+      warn "Line $.: too many input fields\n";
+      last;
+    }
+    if (!$self->{noheredoc} && $line =~ s/^<<(\w+)(?=$sep|$)//) {
+      $data{$self->{fields}[$index++]} = $self->_read_heredoc($1);
+    }
+    elsif ($line =~ s/^\"((?:[^\"\\]|\\(?:[\"\'\\ntr ]|x[\da-fA-F][\da-fA-F]|[0-7]{1,3}))*)\"(?=$sep|$)//) {
+      $data{$self->{fields}[$index++]} = $self->_unescape($1);
+    }
+    elsif ($line =~ s/^NULL\s*(?=$sep|$)//) {
+      $index++;
+    }
+    elsif ($line =~ s/([^$sep]*)(?=$sep|$)//) {
+      $data{$self->{fields}[$index++]} = $1;
+    }
+    else {
+      confess("Internal error: could not parse '$line'");
+    }
+    $line =~ s/^$sep//
+      or last;
+  }
+
+  return \%data;
+}
+
+1;
index 7f23037..733a412 100644 (file)
@@ -109,6 +109,7 @@ sub _load {
   $report{has_params} = @params;
   $report{name} = $cfg->entry($self->{section}, $repid);
   $report{id} = $repid;
+  $report{debug} = $cfg->entry($repsect, 'debug', 0);
 
   my @sql;
   my $sql_index = 1;
@@ -377,12 +378,40 @@ sub _validate_enum {
   }
 }
 
+sub tag_levelN_col {
+  my ($rrow, $args) = @_;
+
+  defined $$rrow 
+    or return '** only inside level1 iterator **';
+
+  exists $$rrow->{$args} or return "** no column $args **";
+
+  escape_html($$rrow->{$args});
+}
+
+sub tag_levelN_sum {
+  my ($rows, $names, $args) = @_;
+
+  exists $names->{$args} or return "** no column $args **";
+
+  my $index = $names->{$args};
+  my $sum = 0;
+  for my $row (@$rows) {
+    $sum += $row->[$index];
+  }
+
+  $sum;
+}
+
 sub show_tags {
   my ($self, $repid, $db, $rmsg, @params) = @_;
 
   # build up result sets
   my $dbh = $db->dbh;
   my $report = $self->_load($repid, undef, $db);
+  if ($report->{debug}) {
+    print STDERR "Params: @params\n";
+  }
   my @results;
   for my $sql (@{$report->{sql}}) {
     my %result;
@@ -392,6 +421,7 @@ sub show_tags {
       return;
     }
     my @sqlp = @params[ map $_-1, @{$sql->{params}} ];
+    $report->{debug} and print STDERR "sql params: @sqlp\n";
     unless ($sth->execute(@sqlp)) {
       $$rmsg = "Error executing $sql->{sql}: ".$dbh->errstr;
       return;
@@ -399,13 +429,16 @@ sub show_tags {
     my @names_lc = @{$sth->{NAME_lc}};
     $result{names} = \@names_lc;
     $result{names_hash} = 
-      map { $names_lc[$_] => $_ } 0 .. $#names_lc;
+      { map { $names_lc[$_] => $_ } 0 .. $#names_lc };
     $result{titles} = [ @{$sth->{NAME}} ];
     my @rows;
     while (my $row = $sth->fetchrow_arrayref) {
       push @rows, [ @$row ];
     }
     $result{rows} = \@rows;
+    if ($report->{debug}) {
+      print STDERR "Result set of ",scalar(@rows)," rows\n";
+    }
 
     push @results, \%result;
   }
@@ -425,10 +458,11 @@ sub show_tags {
 #                            0 .. $#$row 
 #                           };
 #                  } ;
+  my $level1_row;
   my %tags =
     (
      DevHelp::Tags->make_iterator2
-     (undef, 'level1', 'level1', $work[0], \$index[0]),
+     (undef, 'level1', 'level1', $work[0], \$index[0], undef, \$level1_row),
      DevHelp::Tags->make_iterator2
      ([ \&iter_levelN_cols, 0, \@results, $work[0], \$index[0] ], 
       'level1_col', 'level1_cols', undef, undef, 'NoCache'),
@@ -439,7 +473,9 @@ sub show_tags {
      ([ \&iter_levelN_links, 0, $report->{sql}[0]{links}, $work[0], 
        \$index[0] ], 
       'level1_link', 'level1_links', undef, undef, 'NoCache'),
-     
+     level1_col => [ \&tag_levelN_col, \$level1_row ],
+     level1_sum => 
+     [ \&tag_levelN_sum, $results[0]{rows}, $results[0]{names_hash} ],
      report => [ \&tag_hash, $report ],
     );
   for my $level (1 .. $#results) {
index 8be29f9..52e9828 100644 (file)
@@ -46,7 +46,7 @@ sub make_iterator {
 }
 
 sub _iter_reset {
-  my ($rdata, $rindex, $code, $loaded, $nocache, $args, $acts, $name, $templater) = @_;
+  my ($rdata, $rindex, $code, $loaded, $nocache, $rrow, $args, $acts, $name, $templater) = @_;
 
   if (!$$loaded && !@$rdata && $code || $args || $nocache) {
     my ($sub, @args) = $code;
@@ -59,14 +59,22 @@ sub _iter_reset {
   }
 
   $$rindex = -1;
+  defined $rrow and undef $$rrow;
 
   1;
 }
 
 sub _iter_iterate {
-  my ($rdata, $rindex) = @_;
+  my ($rdata, $rindex, $nocache, $rrow) = @_;
 
-  return ++$$rindex < @$rdata;
+  if (++$$rindex < @$rdata) {
+    defined $rrow and $$rrow = $rdata->[$$rindex];
+    return 1;
+  }
+  else {
+    defined $rrow and undef $rrow;
+    return 0;
+  }
 }
 
 sub _iter_if {
@@ -105,7 +113,7 @@ sub _iter_item {
 
 # builds an arrayref based iterator
 sub make_iterator2 {
-  my ($class, $code, $single, $plural, $rdata, $rindex, $nocache) = @_;
+  my ($class, $code, $single, $plural, $rdata, $rindex, $nocache, $rrow) = @_;
 
   my $index;
   defined $rindex or $rindex = \$index;
@@ -115,9 +123,9 @@ sub make_iterator2 {
   return
     (
      "iterate_${plural}_reset" => 
-     [ \&_iter_reset, $rdata, $rindex, $code, \$loaded, $nocache ],
+     [ \&_iter_reset, $rdata, $rindex, $code, \$loaded, $nocache, $rrow ],
      "iterate_${plural}" =>
-     [ \&_iter_iterate, $rdata, $rindex, $nocache ],
+     [ \&_iter_iterate, $rdata, $rindex, $nocache, $rrow ],
      $single => [ \&_iter_item, $rdata, $rindex, $single, $plural ],
      "if\u$plural" => [ \&_iter_if, $rdata, $code, \$loaded, $nocache ],
      "${single}_index" => [ \&_iter_index, $rindex ],
index ba82175..9a06727 100644 (file)
@@ -116,6 +116,12 @@ my %built_ins =
     mindate => '-1d',
     mindatemsg => 'The date entered must be in the future',
    },
+   pastdate => 
+   {
+    date => 1,
+    maxdate => '+1d',
+    maxdatemsg => 'The date entered must be in the past',
+   },
    natural => 
    {
     integer => '0-', # 0 or higher
index 369b9cb..e547cf2 100644 (file)
@@ -10,6 +10,58 @@ Maybe I'll add some other bits here.
 
 =head1 CHANGES
 
+=head2 0.15_18
+
+=over
+
+=item *
+
+added loaddata.pl tool to util directory for use in loading up tables
+with data
+
+=item *
+
+full_access permission now includes all bse_ permissions
+
+=item *
+
+config file entries can now use "here-docs", for example:
+
+  [some section]
+  key=<<EOD
+  some data
+  EOD
+
+this is especially useful for sql statements for reports
+
+=item *
+
+fixed the dynreport tag, a parameter wasn't being passed to the
+handler.
+
+=item *
+
+added level1_col and level1_sum tags to the report tool.
+
+  <:level1_col column_name:>
+
+will extract the column of the given name.
+
+  <:level1_sum column_name:>
+
+will return the sum of that column for the result set.
+
+=item *
+
+you can now set a debug flag for a report.  This doesn't produce much
+information yet.
+
+=item *
+
+added builtin C<pastdate> rule to the validation module.
+
+=back
+
 =head2 0.15_17
 
 Iterim release with subscriptions work.
diff --git a/site/util/loaddata.pl b/site/util/loaddata.pl
new file mode 100644 (file)
index 0000000..967b3cf
--- /dev/null
@@ -0,0 +1,67 @@
+#!perl -w
+use strict;
+use lib '../cgi-bin/modules';
+use DevHelp::LoaderData;
+use DBI;
+use Constants;
+
+my $datadir = shift
+  or die "Usage: $0 directoryname\n";
+
+my $dsn = $Constants::DSN;
+my $dbuser = $Constants::UN;
+my $dbpass = $Constants::PW;
+
+# this is pretty rough, but good enough for now
+my $dbh = DBI->connect($dsn, $dbuser, $dbpass)
+  or die "Cannot connect to database: ",DBI->errstr;
+
+my %tables;
+opendir DATADIR, $datadir or die "Cannot open '$datadir' directory: $!";
+while (my $inname = readdir DATADIR) {
+  (my $table_name = $inname) =~ s/\.data$//
+    or next;
+
+  print "Loading table $table_name\n";
+
+  my @pkey = $dbh->primary_key(undef, $dbuser, $table_name);
+  unless (@pkey) {
+    # look for a file with it
+    open PKEY, "< $datadir/$table_name.pkey"
+      or die "No primary key info found for $table_name";
+    @pkey = <PKEY>;
+    chomp @pkey;
+    @pkey = grep /\S/, @pkey;
+    close PKEY;
+  }
+
+  my $del_sql = "delete from $table_name where "
+    . join(" and ", map "$_ = ?", @pkey);
+
+  open DATA, "< $datadir/$inname"
+    or die "Cannot open $datadir/$inname: $!";
+
+  my $datafile = DevHelp::LoaderData->new(\*DATA)
+    or die;
+
+  while (my $row = $datafile->read) {
+    for my $pkey_col (@pkey) {
+      unless (exists $row->{$pkey_col}) {
+       die "Missing value for $pkey_col in record ending $. of $inname\n";
+      }
+    }
+    defined($dbh->do($del_sql, {}, @{$row}{@pkey}))
+      or die "Error deleting old record: ", DBI->errstr;
+
+    my $add_sql = "insert into $table_name(" .
+      join(",", keys %$row) . ") values (".
+       join(",", ("?") x keys %$row) . ")";
+    defined($dbh->do($add_sql, {}, values %$row))
+      or die "Error adding new record ($add_sql): ", DBI->errstr;
+  }
+  
+  close DATA;
+}
+close DATADIR;
+
+$dbh->disconnect;