site/cgi-bin/modules/BSE/Util/Tags.pm

   1 package BSE::Util::Tags;
   2 use strict;
   3 use HTML::Entities;
   4 use DevHelp::Tags;
   5 use BSE::Util::HTML qw(:default escape_xml);
   6 use vars qw(@EXPORT_OK @ISA);
   7 @EXPORT_OK = qw(tag_error_img tag_hash tag_hash_plain tag_hash_mbcs tag_article tag_article_plain tag_object);
   8 @ISA = qw(Exporter);
   9 require Exporter;
  10
  11 sub _get_parms {
  12   my ($acts, $args) = @_;
  13
  14   my @out;
  15   while (length $args) {
  16     if ($args =~ s/^\s*\[\s*(\w+)(?:\s+(\S[^\]]*))?\]\s*//) {
  17       my ($func, $subargs) = ($1, $2);
  18       if ($acts->{$func}) {
  19         $subargs = '' unless defined $subargs;
  20         push(@out, $acts->{$func}->($subargs));
  21       }
  22     }
  23     elsif ($args =~ s/^\s*\"((?:[^\"\\]|\\[\\\"])*)\"\s*//) {
  24       my $out = $1;
  25       $out =~ s/\\([\\\"])/$1/g;
  26       push(@out, $out);
  27     }
  28     elsif ($args =~ s/^\s*(\S+)\s*//) {
  29       push(@out, $1);
  30     }
  31     else {
  32       last;
  33     }
  34   }
  35
  36   @out;
  37 }
  38
  39 sub bse_strftime {
  40   my ($cfg, $fmt, $sec, $min, $hour, $day, $month, $year, $wday, $yday, $isdst) = @_;
  41
  42   require POSIX;
  43
  44   my $result =
  45     eval {
  46       require Date::Format;
  47       my @when = ( $sec, $min, $hour, $day, $month, $year, $wday, $wday, $isdst );
  48       if ($year < 7000) {
  49         # fix the day of week
  50         @when = localtime POSIX::mktime(@when);
  51       }
  52       # hack in %F support
  53       $fmt =~ s/(?<!%)((?:%%)*)%F/$1%Y-%m-%d/g;
  54       return Date::Format::strftime($fmt, \@when);
  55     };
  56   defined $result
  57     and return $result;
  58
  59   return POSIX::strftime($fmt, $sec, $min, $hour, $day, $month, $year, $wday, $wday, $isdst);
  60 }
  61
  62
  63 sub iter_cfgsection {
  64   my ($cfg, $args, $acts, $tag_name, $templater) = @_;
  65
  66   my $sort_filter = '';
  67   if ($args =~ s/((?:sort|filter)=.*)//s) {
  68     $sort_filter = $1;
  69   }
  70
  71   my ($section) = DevHelp::Tags->get_parms($args, $acts, $templater)
  72     or return;
  73
  74   my %entries = $cfg->entries($section);
  75   my @entries = map +{ key => $_, value => $entries{$_} }, keys %entries;
  76
  77   my %types;
  78
  79   # guess types
  80   unless (grep /\D/, keys %entries) {
  81     $types{key} = 'n';
  82   }
  83   unless (grep /\D/, values %entries) {
  84     $types{value} = 'n';
  85   }
  86
  87   require BSE::Sort;
  88
  89   return BSE::Sort::bse_sort(\%types, $sort_filter, @entries);
  90 }
  91
  92 sub tag_adminbase {
  93   my ($cfg, $arg) = @_;
  94
  95   require BSE::CfgInfo;
  96   return escape_html(BSE::CfgInfo::admin_base_url($cfg));
  97 }
  98
  99 sub static {
 100   my ($class, $acts, $cfg) = @_;
 101
 102   my $static_ajax = $cfg->entry('basic', 'staticajax', 0);
 103   require BSE::Util::Iterate;
 104   my $it = BSE::Util::Iterate->new;
 105   return
 106     (
 107      date =>
 108      sub {
 109        my ($arg, $acts, $name, $templater) = @_;
 110        my ($quote, $fmt, $func, $args) =
 111          $arg =~ m/(?:([\"\'])([^\"\']+)\1\s+)?(\S+)(?:\s+(\S+.*))?/;
 112        $fmt = "%d-%b-%Y" unless defined $fmt;
 113        exists $acts->{$func}
 114          or return "<:date $_[0]:>";
 115        my $date = $templater->perform($acts, $func, $args)
 116          or return '';
 117        my ($year, $month, $day, $hour, $min, $sec) =
 118          $date =~ /(\d+)\D+(\d+)\D+(\d+)(?:\D+(\d+)\D+(\d+)\D+(\d+))?/;
 119        $hour = $min = $sec = 0 unless defined $sec;
 120        $year -= 1900;
 121        --$month;
 122        # passing the isdst as 0 seems to provide a more accurate result than
 123        # -1 on glibc.
 124        return bse_strftime($cfg, $fmt, $sec, $min, $hour, $day, $month, $year, -1, -1, -1);
 125      },
 126      today => [ \&tag_today, $cfg ],
 127      money =>
 128      sub {
 129        my ($arg, $acts, $name, $templater) = @_;
 130        my ($func, $args) = split ' ', $arg, 2;
 131        $args = '' unless defined $args;
 132        exists $acts->{$func}
 133          or return "<: money $func $args :>";
 134        my $value = $templater->perform($acts, $func, $args);
 135        defined $value
 136          or return '';
 137        #$value =~ /\d/
 138        #  or print STDERR "Result '$value' from [$func $args] not a number\n";
 139        $value =~ /\d/ or $value = 0;
 140        sprintf("%.02f", $value/100.0);
 141      },
 142      number => \&tag_number,
 143      bodytext =>
 144      sub {
 145        my ($arg, $acts, $name, $templater) = @_;
 146        my ($func, $args) = split ' ', $arg, 2;
 147
 148        $args = '' unless defined $args;
 149        exists $acts->{$func}
 150          or return "<: bodytext $func $args :>";
 151        my $value = $templater->perform($acts, $func, $args);
 152        defined $value
 153          or return '';
 154
 155        $value = decode_entities($value);
 156        require Generate;
 157        my $gen = Generate->new(cfg=>$cfg);
 158        return $gen->format_body(acts => $acts,
 159                                 articles => 'Articles',
 160                                 text => $value,
 161                                 templater => $templater);
 162      },
 163      nobodytext => [\&tag_nobodytext, $cfg ],
 164      ifEq =>
 165      sub {
 166        my ($arg, $acts, $name, $templater) = @_;
 167        my @args = DevHelp::Tags->get_parms($arg, $acts, $templater);
 168        @args == 2
 169          or die "wrong number of args (@args)";
 170        #print STDERR "ifEq >$left< >$right<\n";
 171        $args[0] eq $args[1];
 172      },
 173      ifMatch =>
 174      sub {
 175        my ($arg, $acts, $name, $templater) = @_;
 176        (my ($left, $right) = DevHelp::Tags->get_parms($arg, $acts, $templater)) == 2
 177          or die; # leaves if in place
 178        $left =~ $right;
 179      },
 180      ifOr =>
 181      sub {
 182        my @args = DevHelp::Tags->get_parms(@_[0,1,3]);
 183        for my $item (@args) {
 184          return 1 if $item;
 185        }
 186        return 0;
 187      },
 188      ifAnd =>
 189      sub {
 190        my @args = DevHelp::Tags->get_parms(@_[0,1,3]);
 191        for my $item (@args) {
 192          return 0 unless $item;
 193        }
 194        return 1;
 195      },
 196      cfg =>
 197      sub {
 198        my ($args, $acts, $myfunc, $templater) = @_;
 199        my ($section, $key, $def) =
 200          DevHelp::Tags->get_parms($args, $acts, $templater);
 201        $cfg or return '';
 202        defined $def or $def = '';
 203        $cfg->entry($section, $key, $def);
 204      },
 205      $it->make_iterator([ \&iter_cfgsection, $cfg ], 'cfgentry', 'cfgsection'),
 206      kb =>
 207      sub {
 208        my ($arg, $acts, $name, $templater) = @_;
 209        my ($key, $args) = split ' ', $arg, 2;
 210        $acts->{$key} or return "<:kb $arg:>";
 211        my $value = $templater->perform($acts, $key, $args);
 212        if ($value > 100000) {
 213          return sprintf("%.0fk", $value/1000.0);
 214        }
 215        elsif ($value > 1000) {
 216          return sprintf("%.1fk", $value/1000.0);
 217        }
 218        else {
 219          return $value;
 220        }
 221      },
 222      release =>
 223      sub {
 224        require BSE::Version;
 225        BSE::Version->version;
 226      },
 227      add =>
 228      sub {
 229        my ($arg, $acts, $name, $templater) = @_;
 230        my @items = DevHelp::Tags->get_parms($arg, $acts, $templater);
 231        my $sum = 0;
 232        $sum += $_ for @items;
 233        $sum;
 234      },
 235      concatenate =>
 236      sub {
 237        my ($arg, $acts, $name, $templater) = @_;
 238        my @items = DevHelp::Tags->get_parms($arg, $acts, $templater);
 239        join '', @items;
 240      },
 241      arithmetic => \&tag_arithmetic,
 242      match =>
 243      sub {
 244        my ($arg, $acts, $name, $templater) = @_;
 245        my ($str, $re, $out, $def)
 246          = DevHelp::Tags->get_parms($arg, $acts, $templater);
 247        $re or return '** no regexp supplied to match **';
 248        $out or $out = '$1';
 249        defined $def or $def = '';
 250        my @matches = $str =~ /$re/
 251          or return $def;
 252        defined or $_ = '' for @matches;
 253
 254        $out =~ s/\$([1-9\$])/
 255          $1 eq '$' ? '$' : $1 <= @matches ? $matches[$1-1] : '' /ge;
 256
 257        $out;
 258      },
 259      replace => \&tag_replace,
 260      lc =>
 261      sub {
 262        my ($arg, $acts, $name, $templater) = @_;
 263        my @items = DevHelp::Tags->get_parms($arg, $acts, $templater);
 264        lc join '', @items;
 265      },
 266      uc =>
 267      sub {
 268        my ($arg, $acts, $name, $templater) = @_;
 269        my @items = DevHelp::Tags->get_parms($arg, $acts, $templater);
 270        uc join '', @items;
 271      },
 272      lcfirst =>
 273      sub {
 274        my ($arg, $acts, $name, $templater) = @_;
 275        my @items = DevHelp::Tags->get_parms($arg, $acts, $templater);
 276        lcfirst join '', @items;
 277      },
 278      ucfirst =>
 279      sub {
 280        my ($arg, $acts, $name, $templater) = @_;
 281        my @items = DevHelp::Tags->get_parms($arg, $acts, $templater);
 282        ucfirst join '', @items;
 283      },
 284      capitalize =>
 285      sub {
 286        my ($arg, $acts, $name, $templater) = @_;
 287        my @items = DevHelp::Tags->get_parms($arg, $acts, $templater);
 288        my $out = join '', @items;
 289        $out = lc $out; # start all lowercase
 290        $out =~ s/(^'?|\W'|[^'\w])(\w)/$1\U$2/g;
 291        $out;
 292      },
 293      adminbase => [ \&tag_adminbase, $cfg ],
 294      help => [ \&tag_help, $cfg, 'user' ],
 295      $it->make_iterator(\&DevHelp::Tags::iter_get_repeat, 'strepeat', 'strepeats'),
 296      report => [ \&tag_report, $cfg ],
 297
 298      # the following is so you can embed a report in another report, since
 299      # report conflicts with a tag name used within reports
 300      subreport => [ \&tag_report, $cfg ],
 301
 302      (
 303       $static_ajax
 304       ? (
 305          ajax => [ \&tag_ajax, $cfg ],
 306          ifAjax => 1,
 307         )
 308       : (
 309          ajax => '',
 310          ifAjax => 0,
 311         )
 312       ),
 313
 314      _format =>
 315      sub {
 316        my ($value, $fmt) = @_;
 317        if ($fmt eq 'u') {
 318          return escape_uri($value);
 319        }
 320        elsif ($fmt eq 'U') {
 321          return escape_uri(unescape_html($value));
 322        }
 323        elsif ($fmt eq 'h') {
 324          return escape_html($value);
 325        }
 326        elsif ($fmt eq 'x') {
 327          return escape_xml(unescape_html($value));
 328        }
 329        elsif ($fmt eq 'z') {
 330          return unescape_html($value);
 331        }
 332        elsif ($fmt eq 'c') {
 333          my $workset = $cfg->entry('html', 'charset', 'iso-8859-1');
 334          require Encode;
 335          my $work = unescape_html($value);
 336          Encode::from_to($work, 'utf8', $workset);
 337          return $work;
 338        }
 339        return $value;
 340      },
 341     );
 342 }
 343
 344 sub tag_arithmetic {
 345   my ($arg, $acts, $name, $templater) = @_;
 346
 347   my $prefix;
 348
 349   if ($arg =~ s/^\s*([^:\s]*)://) {
 350     $prefix = $1;
 351   }
 352   else {
 353     $prefix = '';
 354   }
 355
 356   my $not_found;
 357   $arg =~ s/(\[\s*([^\W\d]\w*)(\s+\S[^\[\]]*)?\s*\])/
 358     exists $acts->{$2} ? $templater->perform($acts, $2, $3)
 359       : (++$not_found, $1)/ge;
 360
 361   if ($not_found) {
 362     if ($prefix eq '') {
 363       return "<:arithmetic $arg:>";
 364     }
 365     else {
 366       return "<:arithmetic $prefix: $arg:>";
 367     }
 368   }
 369
 370   # this may be made more restrictive
 371   my $result = eval $arg;
 372
 373   if ($@) {
 374     print STDERR "code generated by arithmetic: >>$arg<<\n";
 375     return escape_html("** arithmetic error ".$@." **");
 376   }
 377
 378   if ($prefix eq 'i') {
 379     $result = int($result);
 380   }
 381   elsif ($prefix eq 'r') {
 382     $result = sprintf("%.0f", $result);
 383   }
 384   elsif ($prefix =~ /^d(\d+)$/) {
 385     $result = sprintf("%.*f", $1, $result);
 386   }
 387
 388   return escape_html($result);
 389 }
 390
 391 sub tag_nobodytext {
 392   my ($cfg, $arg, $acts, $name, $templater) = @_;
 393   my ($func, $args) = split ' ', $arg, 2;
 394
 395   $args = '' unless defined $args;
 396   exists $acts->{$func}
 397     or return "<: nobodytext $func $args :>";
 398   my $value = $templater->perform($acts, $func, $args);
 399   defined $value
 400     or return '';
 401
 402   $value = decode_entities($value);
 403
 404   require Generate;
 405   my $gen = Generate->new(cfg=>$cfg);
 406   $gen->remove_block('Articles', $acts, \$value);
 407
 408   return escape_html($value);
 409 }
 410
 411 sub tag_old {
 412   my ($cgi, $args, $acts, $name, $templater) = @_;
 413
 414   my ($field, $func, $funcargs);
 415
 416   if ($args =~ /^(\[[^\[\]]*(?:\[[^\[\]]*\][^\[\]]*)*\])(.*)/) {
 417     my ($fieldargs, $rest) = ($1, $2);
 418     ($field) = DevHelp::Tags->get_parms($fieldargs, $acts, $templater);
 419     defined $rest or $rest = '';
 420     ($func, $funcargs) = split ' ', $rest, 2;
 421   }
 422   else {
 423     ($field, $func, $funcargs) = split ' ', $args, 3;
 424   }
 425
 426   my $value = $cgi->param($field);
 427   if (defined $value) {
 428     return escape_html($value);
 429   }
 430
 431   return '' unless $func && exists $acts->{$func};
 432
 433   $value = $templater->perform($acts, $func, $funcargs);
 434   defined $value or $value = '';
 435
 436   return $value;
 437 }
 438
 439 sub tag_oldi {
 440   my ($cgi, $args, $acts, $name, $templater) = @_;
 441
 442   my ($field, $num, $func, @funcargs) =
 443     DevHelp::Tags->get_parms($args, $acts, $templater);
 444
 445   my @values = $cgi->param($field);
 446   if (@values && $num < @values) {
 447     return escape_html($values[$num]);
 448   }
 449
 450   return '' unless $func && exists $acts->{$func};
 451
 452   my $value = $templater->perform($acts, $func, "@funcargs");
 453   defined $value or $value = '';
 454
 455   return $value;
 456 }
 457
 458 sub basic {
 459   my ($class, $acts, $cgi, $cfg) = @_;
 460
 461   require BSE::Util::Iterate;
 462   my $it = BSE::Util::Iterate->new;
 463   return
 464     (
 465      $class->static($acts, $cfg),
 466      script =>
 467      sub {
 468        $ENV{SCRIPT_NAME}
 469      },
 470      cgi =>
 471      sub {
 472        $cgi or return '';
 473        my @value = $cgi->param($_[0]);
 474        escape_html("@value");
 475      },
 476      old => [ \&tag_old, $cgi ],
 477      oldi => [ \&tag_oldi, $cgi ],
 478      $it->make_iterator(\&DevHelp::Tags::iter_get_repeat, 'repeat', 'repeats'),
 479      dynreplace => \&tag_replace,
 480      dyntoday => [ \&tag_today, $cfg ],
 481      dynreport => [ \&tag_report, $cfg ],
 482      ajax => [ \&tag_ajax_dynamic, $cfg ],
 483      ifAjax => [ \&tag_ifAjax, $cfg ],
 484      $it->make_iterator([ \&iter_cfgsection, $cfg ], 'dyncfgentry', 'dyncfgsection'),
 485     );
 486 }
 487
 488 sub common {
 489   my ($class, $req) = @_;
 490
 491   return
 492     (
 493      BSE::Util::Tags->basic(undef, $req->cgi, $req->cfg),
 494      csrfp => [ \&tag_csrfp, $req ],
 495      ifError => 0, # overridden elsewhere
 496     );
 497 }
 498
 499 =item tag csrfp
 500
 501 Generate a token that can be used to prevent cross-site request
 502 forgery.
 503
 504 Takes a single argument, the action to be authenticated.
 505
 506 =cut
 507
 508 sub tag_csrfp {
 509   my ($req, $args) = @_;
 510
 511   $args
 512     or return "** missing required argument **";
 513
 514   my ($name, $type) = split ' ', $args;
 515   defined $type
 516     or $type = 'plain';
 517
 518   my $token = $req->get_csrf_token($name);
 519
 520   $type eq "plain" and return $token;
 521   $type eq "hidden" and return
 522     qq(<input type="hidden" name="_csrfp" value="$token" />);
 523   return "** unknown csrfp type $type **";
 524 }
 525
 526 sub make_iterator {
 527   my ($class, $array, $single, $plural, $saveto) = @_;
 528
 529   my $index;
 530   my @result =
 531       (
 532        "iterate_${plural}_reset" => sub { $index = -1 },
 533        $single => sub { escape_html($array->[$index]{$_[0]}) },
 534        "if\u$plural" => sub { @$array },
 535        "${single}_index" => sub { $index },
 536       );
 537   if ($saveto) {
 538     return
 539       (
 540        @result,
 541        "iterate_${plural}" =>
 542        sub {
 543          if (++$index < @$array) {
 544            $$saveto = $index;
 545            return 1;
 546          }
 547          return 0;
 548        },
 549       );
 550   }
 551   else {
 552     return
 553       (
 554        @result,
 555        "iterate_${plural}" =>
 556        sub { ++$index < @$array },
 557       );
 558   }
 559 }
 560
 561 sub make_dependent_iterator {
 562   my ($class, $base_index, $getdata, $single, $plural, $saveto) = @_;
 563
 564   my $last_base = -1;
 565   my @data;
 566   my $index;
 567   my @result =
 568       (
 569        "iterate_${plural}_reset" =>
 570        sub {
 571          if ($$base_index != $last_base) {
 572            @data = $getdata->($$base_index);
 573            $last_base = $$base_index;
 574          }
 575          $index = -1
 576        },
 577        $single => sub { escape_html($data[$index]{$_[0]}) },
 578        "if\u$plural" =>
 579        sub {
 580          if ($$base_index != $last_base) {
 581            @data = $getdata->($$base_index);
 582            $last_base = $$base_index;
 583          }
 584          @data
 585        },
 586        "${single}_index" => sub { $index },
 587       );
 588   if ($saveto) {
 589     return
 590       (
 591        @result,
 592        "iterate_${plural}" =>
 593        sub {
 594          if (++$index < @data) {
 595            $$saveto = $index;
 596            return 1;
 597          }
 598          return 0;
 599        },
 600       );
 601   }
 602   else {
 603     return
 604       (
 605        @result,
 606        "iterate_${plural}" =>
 607        sub { ++$index < @data },
 608       );
 609   }
 610 }
 611
 612 sub make_multidependent_iterator {
 613   my ($class, $base_indices, $getdata, $single, $plural, $saveto) = @_;
 614
 615   # $base_indicies is an arrayref containing scalar refs
 616   my @last_bases;
 617   my @data;
 618   my $index;
 619   my @result =
 620       (
 621        "iterate_${plural}_reset" =>
 622        sub {
 623          if (join(",", map $$_, @$base_indices) ne join(",", @last_bases)) {
 624            @last_bases = map $$_, @$base_indices;
 625            @data = $getdata->(@last_bases);
 626          }
 627          $index = -1
 628        },
 629        $single => sub { escape_html($data[$index]{$_[0]}) },
 630        "if\u$plural" =>
 631        sub {
 632          if (join(",", map $$_, @$base_indices) ne join(",", @last_bases)) {
 633            @last_bases = map $$_, @$base_indices;
 634            @data = $getdata->(@last_bases);
 635          }
 636          @data
 637        },
 638        "${single}_index" => sub { $index },
 639       );
 640   if ($saveto) {
 641     return
 642       (
 643        @result,
 644        "iterate_${plural}" =>
 645        sub {
 646          if (++$index < @data) {
 647            $$saveto = $index;
 648            return 1;
 649          }
 650          return 0;
 651        },
 652       );
 653   }
 654   else {
 655     return
 656       (
 657        @result,
 658        "iterate_${plural}" =>
 659        sub { ++$index < @data },
 660       );
 661   }
 662 }
 663
 664 sub admin {
 665   my ($class, $acts, $cfg, $req) = @_;
 666
 667   my $oit = BSE::Util::Iterate::Objects->new(cfg => $cfg);
 668   return
 669     (
 670      help => [ \&tag_help, $cfg, 'admin' ],
 671      $oit->make
 672      (
 673       single => "auditentry",
 674       plural => "auditlog",
 675       code => [ iter_auditlog => $class, $req ],
 676      ),
 677     );
 678 }
 679
 680 my %help_styles =
 681   (
 682    admin => {
 683              template => 'admin/helpicon',
 684              prefix => '/admin/help/',
 685             },
 686    user => {
 687             template => 'helpicon',
 688             prefix => '/help/',
 689            },
 690   );
 691
 692 sub tag_stylecfg {
 693   my ($cfg, $style, $args) = @_;
 694
 695   my ($name, $default) = split ' ', $args, 2;
 696
 697   return $cfg->entry("help style $style", $name, $default);
 698 }
 699
 700 sub iter_auditlog {
 701   my ($class, $req, $args, $acts, $funcname, $templater) = @_;
 702
 703   my (@args) = DevHelp::Tags->get_parms($args, $acts, $templater);
 704   require BSE::TB::AuditLog;
 705   return sort { $b->id cmp $a->id }
 706     BSE::TB::AuditLog->getBy(@args);
 707 }
 708
 709 sub tag_help {
 710   my ($cfg, $defstyle, $args) = @_;
 711
 712   my ($file, $entry, $style) = split ' ', $args;
 713
 714   $style ||= $defstyle;
 715
 716   my $template = $cfg->entry("help style $style", 'template')
 717     || $cfg->entry("help style $defstyle", 'template')
 718     || $help_styles{$style}{template}
 719     || $help_styles{$defstyle}{template};
 720   my $prefix = $cfg->entry("help style $style", 'prefix')
 721     || $cfg->entry("help style $defstyle", 'prefix')
 722     || $help_styles{$defstyle}{prefix}
 723     || $help_styles{$defstyle}{prefix};
 724   require BSE::Template;
 725   my %acts=
 726     (
 727      prefix => $prefix,
 728      file => $file,
 729      entry => $entry,
 730      stylename => $style,
 731      stylecfg => [ \&tag_stylecfg, $cfg, $style ],
 732     );
 733
 734   return BSE::Template->get_page($template, $cfg, \%acts,
 735                                  $help_styles{$defstyle}{template});
 736  }
 737
 738 my %dummy_site_article =
 739   (
 740          id=>-1,
 741          parentid=>0,
 742          title=>'Your site',
 743    );
 744
 745 sub tag_if_user_can {
 746   my ($req, $rperms, $args, $acts, $funcname, $templater) = @_;
 747
 748   my $debug = $req->cfg->entry('debug', 'ifUserCan', 0);
 749   $debug
 750     and print STDERR "Handling ifUserCan $args:\n";
 751   my @checks = split /,/, $args;
 752   for my $check (@checks) {
 753     my ($perm, $artname) = split /:/, $check, 2;
 754     $debug
 755       and print STDERR "  Perm: '$perm'\n";
 756     my $article;
 757     if ($artname) {
 758       if ($artname =~ /^\[/) {
 759         my ($workname) = DevHelp::Tags->get_parms($artname, $acts, $templater);
 760         unless ($workname) {
 761           print STDERR "Could not translate '$artname'\n";
 762           return;
 763         }
 764         $artname = $workname;
 765       }
 766       if ($artname =~ /^(-1|\d+)$/) {
 767         if ($artname == -1) {
 768           $article = -1;
 769         }
 770         else {
 771           $article = $artname;
 772         }
 773       }
 774       elsif ($artname =~ /^\w+$/) {
 775         $article = $req->get_object($artname);
 776         unless ($article) {
 777           if (my $artid = $req->cfg->entry('articles', $artname)) {
 778             $article = $artid;
 779           }
 780           elsif ($acts->{$artname}) {
 781             $article = $templater->perform($acts, $artname, 'id');
 782           }
 783           else {
 784             #print STDERR "Unknown article name $artname\n";
 785             die "ENOIMPL: Unknown article name\n";
 786           }
 787         }
 788       }
 789     }
 790     else {
 791       $article = -1;
 792     }
 793
 794     # whew, so we should have an article
 795     $req->user_can($perm, $article)
 796       or return 0;
 797   }
 798
 799   return 1;
 800 }
 801
 802 sub tag_admin_user {
 803   my ($req, $field) = @_;
 804
 805   my $user = $req->user
 806     or return '';
 807   my $value = $user->{$field};
 808   defined $value or $value = '';
 809
 810   return encode_entities($value);
 811 }
 812
 813 sub secure {
 814   my ($class, $req) = @_;
 815
 816   my $perms;
 817   return
 818     (
 819      ifUserCan => [ \&tag_if_user_can, $req, \$perms ],
 820      ifFormLogon => $req->session->{adminuserid},
 821      ifLoggedOn => [ \&tag_if_logged_on, $req ],
 822      adminuser => [ \&tag_admin_user, $req ],
 823     );
 824 }
 825
 826 sub tag_error_img {
 827   my ($cfg, $errors, $args, $acts, $func, $templater) = @_;
 828
 829   my ($arg, $num) = DevHelp::Tags->get_parms($args, $acts, $templater);
 830   #print STDERR "name $arg num $num\n";
 831   return '' unless $errors->{$arg};
 832   my $msg = $errors->{$arg};
 833   if (ref $errors->{$arg}) {
 834     my @errors = @$msg;
 835     return '' unless @$msg > $num && $msg->[$num];
 836     $msg = $msg->[$num];
 837   }
 838   my $images_uri = $cfg->entry('uri', 'images', '/images');
 839   my $image = $cfg->entry('error_img', 'image', "$images_uri/admin/error.gif");
 840   my $width = $cfg->entry('error_img', 'width', 16);
 841   my $height = $cfg->entry('error_img', 'height', 16);
 842   my $encoded = escape_html($msg);
 843   return qq!<img src="$image" alt="$encoded" title="$encoded" width="$width" height="$height" border="0" align="top" />!;
 844 }
 845
 846 sub tag_replace {
 847   my ($arg, $acts, $name, $templater) = @_;
 848   my ($str, $re, $with, $global)
 849     = DevHelp::Tags->get_parms($arg, $acts, $templater);
 850   $re or return '** no regexp supplied to match **';
 851   defined $with or $with = '$1';
 852   if ($global) {
 853     $str =~ s{$re}
 854       {
 855         # yes, this sucks
 856         my @out = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
 857         defined or $_ = '' for @out;
 858         my $tmp = $with;
 859         {
 860           $tmp =~ s/\$([1-9\$])/
 861             $1 eq '$' ? '$' : $out[$1-1] /ge;
 862         }
 863         $tmp;
 864       }ge;
 865   }
 866   else {
 867     $str =~ s{$re}
 868       {
 869         # yes, this sucks
 870         my @out = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
 871         defined or $_ = '' for @out;
 872         my $tmp = $with;
 873         {
 874           $tmp =~ s/\$([1-9\$])/
 875             $1 eq '$' ? '$' : $out[$1-1] /ge;
 876         }
 877         $tmp;
 878       }e;
 879   }
 880
 881   $str;
 882 }
 883
 884 sub tag_hash {
 885   my ($hash, $args) = @_;
 886
 887   my $value = $hash->{$args};
 888   defined $value or $value = '';
 889   if ($value =~ /\cJ/ && $value =~ /\cM/) {
 890     $value =~ tr/\cM//d;
 891   }
 892
 893   escape_html($value);
 894 }
 895
 896 sub tag_hash_mbcs {
 897   my ($object, $args) = @_;
 898
 899   my $value = $object->{$args};
 900   defined $value or $value = '';
 901   if ($value =~ /\cJ/ && $value =~ /\cM/) {
 902     $value =~ tr/\cM//d;
 903   }
 904   escape_html($value, '<>&"');
 905 }
 906
 907 sub tag_hash_plain {
 908   my ($hash, $args) = @_;
 909
 910   my $value = $hash->{$args};
 911   defined $value or $value = '';
 912
 913   $value;
 914 }
 915
 916 sub tag_object {
 917   my ($object, $args, $acts, $func) = @_;
 918
 919   $object or return '';
 920
 921   $object->can($args)
 922     or return "** $func has no method $args **";
 923
 924   my $value = $object->$args();
 925   defined $value or return "";
 926
 927   return escape_html($value);
 928 }
 929
 930 sub tag_today {
 931   my ($cfg, $args) = @_;
 932
 933   $args =~ s/^"(.+)"$/$1/;
 934
 935   $args ||= "%d-%b-%Y";
 936
 937   return bse_strftime($cfg, $args, localtime);
 938 }
 939
 940 sub tag_report {
 941   my ($cfg, $args, $acts, $tag_name, $templater) = @_;
 942
 943   my ($rep_name, $template, @args) =
 944     DevHelp::Tags->get_parms($args, $acts, $templater);
 945   defined $rep_name
 946     or return "** no report name supplied to $tag_name tag **";
 947
 948   require BSE::Report;
 949   my $reports = BSE::Report->new($cfg);
 950   my $report = $reports->load($rep_name, undef, BSE::DB->single);
 951   $report
 952     or return "** could not load report '$rep_name' **";
 953
 954   # this will get embedded and normal tag replacement will then
 955   # operate on it, no need to include basic/static tags
 956   my %acts;
 957   my $msg;
 958   %acts =
 959     (
 960      %$acts,
 961      $reports->show_tags($rep_name, BSE::DB->single, \$msg, @args),
 962     );
 963
 964   $msg
 965     and return "** error in $tag_name: $msg **";
 966
 967   if (!defined $template or $template eq '-') {
 968     $template = $reports->show_template($rep_name) || 'admin/reports/show1';
 969   }
 970
 971   my $html = BSE::Template->get_source($template, $cfg);
 972   if ($html =~ /<:\s*embed\s*start\s*:>(.*)<:\s*embed\s*end\s*:>/s
 973      || $html =~ m"<\s*body[^>]*>(.*)<\s*/\s*body>"s) {
 974     $html = $1;
 975   }
 976
 977   return BSE::Template->replace($html, $cfg, \%acts);
 978 }
 979
 980 sub _if_ajax {
 981   my ($cfg) = @_;
 982
 983   return
 984     unless $cfg->entry('basic', 'ajax', 0);
 985
 986   return 1
 987     if $cfg->entry('basic', 'allajax', 0);
 988
 989   my $ua = $ENV{HTTP_USER_AGENT};
 990   defined $ua or $ua = ''; # some clients don\'t send a UA # silly cperl
 991
 992   my %fail_entries = $cfg->entries('nonajax user agents');
 993   for my $re (values %fail_entries) {
 994     return
 995       if $ua =~ /$re/;
 996   }
 997
 998   my %entries = $cfg->entries('ajax user agents');
 999   for my $re (values %entries) {
1000     return 1
1001       if $ua =~ /$re/;
1002   }
1003
1004   return;
1005 }
1006
1007 sub tag_ifAjax {
1008   my ($cfg) = @_;
1009
1010   return _if_ajax($cfg) ? 1 : 0;
1011 }
1012
1013 sub tag_ajax_dynamic {
1014   my ($cfg, $args, $acts, $tag_name, $templater) = @_;
1015
1016   return '' unless _if_ajax($cfg);
1017
1018   return tag_ajax($cfg, $args, $acts, $tag_name, $templater);
1019 }
1020
1021 sub tag_ajax {
1022   my ($cfg, $args, $acts, $tag_name, $templater) = @_;
1023
1024   my ($name, $arg_rest) = split ' ', $args, 2;
1025
1026   my $defn = $cfg->entry('ajax definitions', $name)
1027     or return "** unknown ajax definition $name **";
1028   my ($type, $rest) = split ':', $defn, 2;
1029
1030   defined $arg_rest or $arg_rest = '';
1031
1032   if ($type eq 'inline') {
1033     # just replace $1, $2, etc in the rest of the text
1034     my @args = DevHelp::Tags->get_parms($arg_rest, $acts, $templater);
1035     my $macro = $rest;
1036     eval {
1037       $macro =~ s/(\$([1-9\$]))/
1038         $2 eq '$' ? '$' : $2 <= @args
1039          ? die "** not enough parameters for ajax definition $name **\n" : $args[$1-1]/xge;
1040     };
1041     $@ and return $@;
1042
1043     return $macro;
1044   }
1045   else {
1046     return "** invalid type $type for ajax definition $name **";
1047   }
1048 }
1049
1050 sub tag_article {
1051   my ($article, $cfg, $args) = @_;
1052
1053   return escape_html(tag_article_plain($article, $cfg, $args));
1054 }
1055
1056 sub tag_article_plain {
1057   my ($article, $cfg, $args) = @_;
1058
1059   my $value;
1060   if ($args eq 'link'
1061      && ref($article) ne 'HASH') {
1062     $value = $article->link($cfg);
1063   }
1064   else {
1065     $value = $article->{$args};
1066     defined $value or $value = '';
1067     if ($value =~ /\cJ/ && $value =~ /\cM/) {
1068       $value =~ tr/\cM//d;
1069     }
1070   }
1071
1072   return $value;
1073 }
1074
1075 sub tag_number {
1076   my ($args, $acts, $tagname, $templater) = @_;
1077
1078   my ($format, $value) =
1079     DevHelp::Tags->get_parms($args, $acts, $templater);
1080   $format or return "* no number format *";
1081   my $section = "number $format";
1082   my $cfg = BSE::Cfg->single;
1083   my $comma_sep = $cfg->entry($section, "comma", ",");
1084   $comma_sep =~ s/^"(.*)"$/$1/;
1085   $comma_sep =~ /\w/ and return "* comma cannot be a word character *";
1086   my $comma_limit = $cfg->entry($section, "comma_limit", 1000);
1087   my $commify = $cfg->entry($section, "commify", 1);
1088   my $dec_sep = $cfg->entry($section, "decimal", ".");
1089   my $div = $cfg->entry($section, "divisor", 1)
1090     or return "* divisor must be non-zero *";
1091   my $places = $cfg->entry($section, "places", -1);
1092
1093   my $div_value = $value / $div;
1094   my $formatted = $places < 0 ? $div_value : sprintf("%.*f", $places, $div_value);
1095
1096   my ($int, $frac) = split /\./, $formatted;
1097   if ($commify && $int >= $comma_limit) {
1098     1 while $int =~ s/([0-9])([0-9][0-9][0-9]\b)/$1$comma_sep$2/;
1099   }
1100
1101   if (defined $frac) {
1102     return $int . $dec_sep . $frac;
1103   }
1104   else {
1105     return $int;
1106   }
1107 }
1108
1109 1;
1110