0.15_52 commit r0_15_52
authorTony Cook <tony@develop-help.com>
Mon, 20 Nov 2006 03:37:32 +0000 (03:37 +0000)
committertony <tony@45cb6cf1-00bc-42d2-bb5a-07f51df49f94>
Mon, 20 Nov 2006 03:37:32 +0000 (03:37 +0000)
16 files changed:
Makefile
site/cgi-bin/modules/BSE/CfgInfo.pm
site/cgi-bin/modules/BSE/CustomBase.pm
site/cgi-bin/modules/BSE/Edit/Article.pm
site/cgi-bin/modules/BSE/Edit/Seminar.pm
site/cgi-bin/modules/BSE/Formatter.pm
site/cgi-bin/modules/BSE/Request.pm
site/cgi-bin/modules/BSE/UserReg.pm
site/cgi-bin/modules/BSE/Util/Tags.pm
site/cgi-bin/modules/DevHelp/Formatter.pm
site/cgi-bin/modules/DevHelp/Payments/SecurePayXML.pm
site/cgi-bin/modules/Squirrel/Template.pm
site/cgi-bin/user.pl
site/docs/bse.pod
site/docs/config.pod
test.cfg

index abf1595..b1f748b 100755 (executable)
--- a/Makefile
+++ b/Makefile
@@ -1,4 +1,4 @@
-VERSION=0.15_51
+VERSION=0.15_52
 DISTNAME=bse-$(VERSION)
 DISTBUILD=$(DISTNAME)
 DISTTAR=../$(DISTNAME).tar
index 742bc41..1312d50 100644 (file)
@@ -22,6 +22,9 @@ BSE::CfgInfo - functions that return information derived from configuration
   use BSE::CfgInfo 'credit_card_class';
   my $class = credit_card_class($cfg);
 
+  use BSE::CfgInfo 'product_options';
+  my $options = product_options($cfg);
+
 =head1 DESCRIPTION
 
 This module contains functions which examine the BSE configuration and
@@ -29,7 +32,9 @@ return information useful at the application level.
 
 =over
 
-=item admin_base_url($cfg)
+=item custom_class
+
+Returns an object of the class of the configured custom class.
 
 =cut
 
@@ -49,6 +54,10 @@ sub custom_class {
   return $class->new(cfg=>$cfg);
 }
 
+=item admin_base_url($cfg)
+
+=cut
+
 sub admin_base_url {
   my ($cfg) = @_;
 
@@ -72,6 +81,12 @@ sub cfg_image_dir {
   $cfg->entry('paths', 'images', $Constants::IMAGEDIR);
 }
 
+=item credit_card_class
+
+Loads the configured credit card class and instantiates it.
+
+=cut
+
 sub credit_card_class {
   my ($cfg) = @_;
 
@@ -89,6 +104,30 @@ sub credit_card_class {
   return $class->new($cfg);
 }
 
+=item product_options
+
+Returns a hashref of product options, where the key is the option id,
+the values are each a hashref with the following keys:
+
+=over
+
+=item *
+
+desc - description of the option
+
+=item *
+
+values - array ref of possible values for the option
+
+=item *
+
+labels - hashref of labels for the different values.  This is always
+filled out with the labels defaulting to the values.
+
+=back
+
+=cut
+
 sub product_options {
   my ($cfg) = @_;
 
index 22f5313..4acea19 100644 (file)
@@ -193,6 +193,10 @@ Defines extra tags for use on any page.
 
 Called when a change is made to the site users table.
 
+=item $self->siteuser_save($user, $req)
+
+Called at the beginning of the save_opts() action.
+
 =back
 
 =cut
index 89dfcf9..b125094 100644 (file)
@@ -9,6 +9,7 @@ use DevHelp::HTML qw(:default popup_menu);
 use BSE::Arrows;
 use BSE::CfgInfo qw(custom_class admin_base_url cfg_image_dir);
 use BSE::Util::Iterate;
+use BSE::Template;
 
 sub article_dispatch {
   my ($self, $req, $article, $articles) = @_;
@@ -732,7 +733,7 @@ sub tag_movechild {
 }
 
 sub tag_edit_link {
-  my ($article, $args, $acts, $funcname, $templater) = @_;
+  my ($cfg, $article, $args, $acts, $funcname, $templater) = @_;
   my ($which, $name) = split / /, $args, 2;
   $name ||= 'Edit';
   my $gen_class;
@@ -740,7 +741,7 @@ sub tag_edit_link {
       && ($gen_class = $templater->perform($acts, $which, 'generator'))) {
     eval "use $gen_class";
     unless ($@) {
-      my $gen = $gen_class->new(top => $article);
+      my $gen = $gen_class->new(top => $article, cfg => $cfg);
       my $link = $gen->edit_link($templater->perform($acts, $which, 'id'));
       return qq!<a href="$link">$name</a>!;
     }
@@ -1124,7 +1125,7 @@ sub low_edit_tags {
      (\&iter_admin_users, 'iadminuser', 'adminusers'),
      DevHelp::Tags->make_iterator2
      (\&iter_admin_groups, 'iadmingroup', 'admingroups'),
-     edit => [ \&tag_edit_link, $article ],
+     edit => [ \&tag_edit_link, $cfg, $article ],
      error => [ $tag_hash, $errors ],
      error_img => [ \&tag_error_img, $cfg, $errors ],
      ifFieldPerm => [ \&tag_if_field_perm, $request, $article ],
@@ -1164,7 +1165,6 @@ sub edit_template {
   my $t = $cgi->param('_t');
   if ($t && $t =~ /^\w+$/) {
     $base = $t;
-    $cgi->delete('_t');
   }
   return $self->{cfg}->entry('admin templates', $base, 
                             "admin/edit_$base");
@@ -1186,7 +1186,7 @@ sub low_edit_form {
   my $template = $article->{id} ? 
     $self->edit_template($article, $cgi) : $self->add_template($article, $cgi);
 
-  return $request->dyn_response($template, \%acts);
+  return $request->response($template, \%acts);
 }
 
 sub edit_form {
index 113d867..66bd751 100644 (file)
@@ -33,7 +33,6 @@ sub edit_template {
   my $t = $cgi->param('_t');
   if ($t && $t =~ /^\w+$/) {
     $base = $t;
-    $cgi->delete('_t');
   }
   return $self->{cfg}->entry('admin templates', $base, 
                             "admin/edit_$base");
index 8873aa7..1b4e0f3 100644 (file)
@@ -35,6 +35,9 @@ sub new {
   if ($cfg->entry('html', 'mbcs', 0)) {
     $self->{conservative_escape} = 1;
   }
+  elsif ($cfg->entry('html', 'msentify', 0)) {
+    $self->{msentify} = 1;
+  }
 
   $self;
 }
index 28478db..1fb257b 100644 (file)
@@ -20,6 +20,15 @@ sub new {
     @{$self}{qw/siteuser_calls siteuser_cached has_access_cached has_access_total/} = ( 0, 0, 0, 0 );
   }
 
+  if ($self->cfg->entry('html', 'utf8decodeall')) {
+    $self->_encode_utf8();
+  }
+  elsif ($self->cfg->entry('html', 'ajaxcharset', 0)
+      && (() = $self->cgi->param('_'))) {
+    # convert the values of each parameter from UTF8 to iso-8859-1
+    $self->_convert_utf8_cgi_to_charset();
+  }
+
   $self;
 }
 
@@ -199,7 +208,14 @@ sub dyn_response {
 sub response {
   my ($req, $template, $acts) = @_;
 
-  return BSE::Template->get_response($template, $req->cfg, $acts);
+  require BSE::Template;
+  my @sets;
+  if ($template =~ m!^admin/!) {
+    @sets = $req->template_sets;
+  }
+
+  return BSE::Template->get_response($template, $req->cfg, $acts, 
+                                    $template, \@sets);
 }
 
 # get the current site user if one is logged on
@@ -420,4 +436,49 @@ sub text {
   $default;
 }
 
+sub _convert_utf8_cgi_to_charset {
+  my ($self) = @_;
+
+  require Encode;
+  my $cgi = $self->cgi;
+  my $workset = $self->cfg->entry('html', 'charset', 'iso-8859-1');
+  my $decoded = $self->cfg->entry('html', 'cgi_decoded', 1);
+  
+  # avoids param decoding the data
+  $cgi->charset($workset);
+
+  print STDERR "Converting parameters from UTF8 to $workset\n"
+    if $self->cfg->entry('debug', 'convert_charset');
+
+  if ($decoded) {
+    # CGI.pm has already converted it from utf8 to perl's internal encoding
+    # so we just need to encode to the working encoding
+    # I don't see a reliable way to detect this without configuring it
+    for my $name ($cgi->param) {
+      my @values = map Encode::encode($workset, $_), $cgi->param($name);
+
+      $cgi->param($name => @values);
+    }
+  }
+  else {
+    for my $name ($cgi->param) {
+      my @values = $cgi->param($name);
+      Encode::from_to($_, $workset, 'utf8') for @values;
+      $cgi->param($name => @values);
+    }
+  }
+}
+
+sub _encode_utf8 {
+  my ($self) = @_;
+
+  my $cgi = $self->cgi;
+
+  require Encode;
+  for my $name ($cgi->param) {
+    my @values = map Encode::encode('utf8', $_), $cgi->param($name);
+    $cgi->param($name => @values);
+  }
+}
+
 1;
index f078302..7e51219 100644 (file)
@@ -483,6 +483,17 @@ sub saveopts {
 
   my $user = $self->_get_user($req)
     or return;
+
+  if ($cfg->entry('custom', 'saveopts')) {
+    my $custom = custom_class($cfg);
+    eval {
+      $custom->siteuser_saveopts($user, $req);
+    };
+    if ($@) {
+      return $self->show_opts($req, $@);
+    }
+  }
+
   my $nopassword = $cfg->entryBool('site users', 'nopassword', 0);
   my %errors;
   my $newpass;
index 4013957..a1a1f47 100644 (file)
@@ -78,8 +78,8 @@ sub static {
      date =>
      sub {
        my ($arg, $acts, $name, $templater) = @_;
-       my ($fmt, $func, $args) = 
-        $arg =~ m/(?:\"([^\"]+)\"\s+)?(\S+)(?:\s+(\S+.*))?/;
+       my ($quote, $fmt, $func, $args) = 
+        $arg =~ m/(?:([\"\'])([^\"\']+)\1\s+)?(\S+)(?:\s+(\S+.*))?/;
        $fmt = "%d-%b-%Y" unless defined $fmt;
        require 'POSIX.pm';
        exists $acts->{$func}
@@ -292,6 +292,13 @@ sub static {
        elsif ($fmt eq 'z') {
         return unescape_html($value);
        }
+       elsif ($fmt eq 'c') {
+        my $workset = $cfg->entry('html', 'charset', 'iso-8859-1');
+        require Encode;
+        my $work = unescape_html($value);
+        Encode::from_to($work, 'utf8', $workset);
+        return $work;
+       }
        return $value;
      },
     );  
index fff4a18..3705563 100644 (file)
@@ -485,12 +485,54 @@ sub _cleanup_table {
   return join(' ', @lines);
 }
 
+my %ms_entities =
+  (
+   34 => 'quot',
+   60 => 'lt',
+   62 => 'gt',
+   38 => 'amp',
+   128 => '#x20ac',
+   130 => '#x201a',
+   131 => '#x192',
+   132 => '#x201e',
+   133 => '#x2026',
+   134 => '#x2020',
+   135 => '#x2021',
+   136 => '#x2c6',
+   137 => '#x2030',
+   138 => '#x160',
+   139 => '#x2039',
+   140 => '#x152',
+   142 => '#x17D',
+   145 => 'lsquo',
+   146 => 'rsquo',
+   147 => 'ldquo',
+   148 => 'rdquo',
+   149 => '#x2022',
+   150 => 'ndash',
+   151 => 'mdash',
+   152 => '#x2dc',
+   153 => 'trade',
+   154 => '#x161',
+   155 => '#x203a',
+   156 => '#x153',
+   158 => '#x17e',
+   159 => '#x178',
+  );
+
 sub escape {
   my ($self, $html) = @_;
 
   if ($self->{conservative_escape}) {
     return escape_html($html, '<>&"');
   }
+  elsif ($self->{msentify}) {
+    $html =~ s{([<>&\"\x80-\x9F])}
+      { $ms_entities{ord $1} ? "&$ms_entities{ord $1};" 
+             : "** unknown code ".ord($1). " **"; }ge;
+
+    return $html;
+  }
   else {
     return escape_html($html);
   }
index 2d8ebe3..b936063 100644 (file)
@@ -4,7 +4,7 @@ use Carp 'confess';
 use Digest::MD5 qw(md5_hex);
 use POSIX qw(strftime);
 use LWP::UserAgent;
-use XML::Simple;
+use XML::Parser;
 
 my $sequence = 0;
 
@@ -152,9 +152,10 @@ sub _request_low {
     print STDERR "Raw response: $result_content\n";
   }
 
-  my $tree;
+  my $toptree;
   eval {
-    $tree = XMLin($result_content);
+    my $parser = XML::Parser->new(Style => 'Tree');
+    $toptree = $parser->parse($result_content);
   };
   if ($@) {
     $$result =
@@ -169,14 +170,25 @@ sub _request_low {
   if ($self->{debug}) {
     require Data::Dumper;
     Data::Dumper->import();
-    print STDERR "Response parsed: ",Dumper($tree);
+    print STDERR "Response parsed: ",Dumper($toptree);
   }
 
   my $paranoid = $self->{paranoid};
+
+  if ($paranoid && $toptree->[0] ne 'SecurePayMessage') {
+    $$result = 
+      {
+       success => 0,
+       error => 'Root element not SecurePayMessage',
+       statuscode => -1,
+      };
+  }
+
+  my $tree = $toptree->[1];
   
   if ($paranoid) {
     # check the message id
-    my $infotag = $tree->{MessageInfo};
+    my $infotag = _find_element($tree, 'MessageInfo');
     unless ($infotag) {
       $$result =
        { 
@@ -186,12 +198,15 @@ sub _request_low {
        };
       return;
     }
-      
-    unless ($infotag->{messageID} eq $message_id) {
+    
+    # extract the message id
+    my $parse_message_id = _find_value($infotag, 'messageID');
+    
+    unless ($parse_message_id && $parse_message_id eq $message_id) {
       $$result =
        { 
         sucess => 0, 
-        error=>"MessageID doesn't match", 
+        error=>"messageID doesn't match", 
         statuscode=> -1 
        };
       return;
@@ -235,6 +250,46 @@ my $payment_template = <<'XML';
 </SecurePayMessage>
 XML
 
+sub _find_element {
+  my ($tree, $tag) = @_;
+
+  my $index = 1;
+  while ($index < @$tree) {
+    if ($tree->[$index] eq $tag) {
+      return $tree->[$index+1];
+    }
+    ++$index;
+  }
+
+  return;
+}
+
+# extract the plain text value of an element
+# returns () if not found or if the element isn't a plain value
+sub _find_value {
+  my ($tree, $tag) = @_;
+
+  my $element = _find_element($tree, $tag)
+    or return;
+  @$element == 3 && $element->[1] == 0
+    or return;
+
+  return $element->[1];
+}
+
+# returns status code, status description as a list
+sub _extract_status {
+  my ($tree) = @_;
+  
+  my $status = _find_element($tree, 'Status')
+    or return;
+
+  return (
+         scalar(_find_value($status, 'statusCode')),
+         scalar(_find_value($status, 'statusDescription'))
+        );
+}
+
 sub payment {
   my ($self, %args) = @_;
 
@@ -293,39 +348,39 @@ sub payment {
   $self->_request(\%replace, $payment_template, \$result, \$tree)
     or return $result;
 
-  my $status_ele = $tree->{Status}
+  my ($status_code, $status_desc) = _extract_status($tree)
     or return { success => 0, error => 'Response missing Status element', statuscode => -1 };
-  if ($status_ele->{statusCode} != 0) {
+  if ($status_code != 0) {
     return {
            success => 0,
-           error => $status_ele->{statusDescription},
-           statuscode => $status_ele->{statusCode}
+           error => $status_desc,
+           statuscode => $status_code
           };
   }
 
-  my $payment_ele = $tree->{Payment}
+  my $payment_ele = _find_element($tree, 'Payment')
     or return { success => 0, error => 'Response missing Payment element', statuscode => -1 };
-  my $txnlist_ele = $payment_ele->{TxnList}
+  my $txnlist_ele = _find_element($payment_ele, 'TxnList')
     or return { success =>0, error => 'Response missiog TxnList element', statuscode => -1 };
-  $txnlist_ele->{count} == 1
+  $txnlist_ele->[0]{count} == 1
     or return { success => 0, error => 'Response has more or less than 1 transaction', statuscode => -1 };
-  my $txn_ele = $txnlist_ele->{Txn}
+  my $txn_ele = _find_element($txnlist_ele,, 'Txn')
     or return { success => 0, error => 'Response missing Txn element', statuscode => -1 };
-  if ($txn_ele->{approved} eq 'Yes') {
+  if (_find_value($txn_ele, 'approved') eq 'Yes') {
     return
       {
        success => 1,
-       statuscode => $txn_ele->{responseCode},
-       error => $txn_ele->{responseText},
-       receipt => $txn_ele->{txnID},
+       statuscode => scalar(_find_value($txn_ele, 'responseCode')),
+       error => scalar(_find_value($txn_ele, 'responseText')),
+       receipt => scalar(_find_value($txn_ele, 'txnID')),
       };
   }
   else {
     return
       {
        success => 0,
-       statuscode => $txn_ele->{responseCode},
-       error => $txn_ele->{responseText},
+       statuscode => scalar(_find_value($txn_ele, 'responseCode')),
+       error => scalar(_find_value($txn_ele, 'responseText')),
       };
   }
 }
index 5a12409..92d937d 100644 (file)
@@ -351,7 +351,7 @@ sub switch {
 sub tag_param {
   my ($params, $arg) = @_;
 
-  exists $params->{$arg} or return "<:param $arg:>";
+  exists $params->{$arg} or return "";
 
   $params->{$arg};
 }
index 462416e..b6e8952 100755 (executable)
@@ -1,6 +1,6 @@
 #!/usr/bin/perl -w
 # -d:ptkdb
-BEGIN { $ENV{DISPLAY} = '192.168.32.15:0.0'; }
+BEGIN { $ENV{DISPLAY} = '192.168.32.50:0.0'; }
 use strict;
 use FindBin;
 use lib "$FindBin::Bin/modules";
index d7bc3fd..2d543a8 100644 (file)
@@ -10,6 +10,25 @@ Maybe I'll add some other bits here.
 
 =head1 CHANGES
 
+=head2 0.15_52
+
+=over
+
+=item *
+
+added a custom hook to the saveopts target in user.pl.  You need to
+set [custom].saveopts=1 for this hook to be called.
+
+=item *
+
+various minor hacks to try and get utf8 output in some cases.
+
+=item *
+
+undefined <:param name:> tags are now returned as empty strings
+
+=back
+
 =head2 0.15_51
 
 There are additions to [pregenerate] in bse.cfg in this release.
index 453acca..f108103 100644 (file)
@@ -1455,6 +1455,18 @@ The password to supply to test requests.
 
 =back
 
+=head2 [custom]
+
+This section controls whether some custom class methods are called:
+
+=over
+
+=item saveopts
+
+If this is non-zero then siteuser_saveopts is called.
+
+=back
+
 =head1 AUTHOR
 
 Tony Cook <tony@develop-help.com>
index b5cb94a..79cfdc8 100644 (file)
--- a/test.cfg
+++ b/test.cfg
@@ -59,6 +59,8 @@ debug.mail_encryption=0
 site users.billing_on_main_opts=0
 #site users.user_register=0
 #paths.libraries=/home/tony/dev/bse/tandb_dealer/cvs/modules
+paths.libraries=/home/tony/dev/bse/lib
+basic.custom_class=BSE::Custom::Abberfield
 #paths.siteuser_passwd=/home/httpd/bsetest/data/supasswd
 #custom.user_auth=1
 # product fields.retailPrice=Dealer Price Inc GST
@@ -85,6 +87,8 @@ dealer.accountno=77777777
 shop.display_facsimile=Fax Number
 site user flags.a=Access to private pages
 tandb custom.siteuser_include_flag=a
+site user flags.d=Demo user
+custom.saveopts=1
 
 #test.1=hello
 #test.2=alpha
@@ -238,3 +242,7 @@ shop product options.book_flight=Flight Booking;Book a flight;Don't book a fligh
 seminars.free_bookings=1
 
 admin group template sets.test=Test Templates
+
+html.msentify=1
+html.ajaxcharset=1
+debug.convert_charset=1