home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / templnew.pl < prev    next >
Text File  |  2009-11-06  |  16KB  |  513 lines
  1. # FILE: templnew.pl
  2. # DESCRIPTION: Template Interpreter (convert to Perl and run)
  3. #-------------------------------------------------------------------------------
  4. # DISCUS COPYRIGHT NOTICE
  5. #
  6. # Discus is copyright (c) 2002 by DiscusWare, LLC, all rights reserved.
  7. # The use of Discus is governed by the Discus License Agreement which is
  8. # available from the Discus WWW site at:
  9. #    http://www.discusware.com/discus/license
  10. #
  11. # Pursuant to the Discus License Agreement, this copyright notice may not be
  12. # removed or altered in any way.
  13. #-------------------------------------------------------------------------------
  14.  
  15. use strict;
  16. use vars qw($GLOBAL_OPTIONS $DCONF $PARAMS);
  17.  
  18. ###
  19. ### dtl_interpret
  20. ###
  21. ### Handler for output of text
  22. ###
  23.  
  24. sub dtl_interpret {
  25.     my ($filename, $substitutions) = @_;
  26.     if ($filename =~ /^\*/) {
  27.         return dtl_interpret_skin($', $substitutions);
  28.     } else {
  29.         return dtl_interpret_template($filename, $substitutions);
  30.     }
  31. }
  32.  
  33. ###
  34. ### dtl_interpret_skin
  35. ###
  36. ### Skin interpreter
  37. ###
  38.  
  39. sub dtl_interpret_skin {
  40.     my ($filename, $substitutions, $skip) = @_;
  41.     $filename =~ s/\W/_/g;
  42.     my $topic = 0; my $after = $'; my $skininit = "";
  43.     if (! defined $substitutions->{'_ALTCOLOR'}) {
  44.         $substitutions = basic_substitutions($substitutions);
  45.     }
  46.     if (! defined $substitutions->{'color_override'}) {
  47.         $substitutions = color_substitutions($substitutions);
  48.     }
  49.     if ($filename =~ /^(\d+)/ && $1 > 0) {
  50.         $filename = join("", "SKIN_$1", "_$'");
  51.         $topic = $1;
  52.         $after = $filename;
  53.         $skininit = join("", "SKIN_$topic", "_INIT");
  54.     } else {
  55.         $filename = "SKIN_$filename";
  56.         $after = $filename;
  57.         $skininit = join("", "SKIN_INIT");
  58.     }
  59.     my $d = "$DCONF->{admin_dir}/data/tcache";
  60.     if (defined $PARAMS->{templates}->{$filename} && defined $PARAMS->{templates}->{$skininit}) {
  61.         return 1 if $skip;
  62.         performance_string("* Using cached skin for $filename");
  63.         my $varname1 = join('::', $PARAMS->{templates}->{$skininit}, 'process');
  64.         $substitutions = (&{\&{$varname1}}($substitutions))[1];
  65.         my $varname2 = join('::', $PARAMS->{templates}->{$filename}, 'process');
  66.         return &{\&{$varname2}}($substitutions);
  67.     } else {
  68.         if (! -e "$DCONF->{admin_dir}/data/tcache") {
  69.             if (mkdir "$DCONF->{admin_dir}/data/tcache", oct($DCONF->{perms0777})) {
  70.                 chmod oct($DCONF->{perms0777}), "$DCONF->{admin_dir}/data/tcache";
  71.             } else {
  72.                 barf_tcache($!);
  73.             }
  74.         }
  75.         my $skinpath = dtl_grab_skin($topic);
  76.         my $default = "$DCONF->{admin_dir}/skins/$GLOBAL_OPTIONS->{'skinchoice'}.tmpl";
  77.         if ($topic != 0 && $skinpath eq $default) {
  78.              my $z = join("", "$d/SKIN_$topic", "_$after.pl");
  79.              if (! -e $z && open (FILE, "< $d/SKIN_$after.pl")) {
  80.                  open (FILEOUT, "> $z");
  81.                  while (<FILE>) {
  82.                      print FILEOUT;
  83.                  }
  84.                  close (FILE);
  85.                  close (FILEOUT);
  86.             }
  87.         }
  88.         my $z = "$d/$after.pl";
  89.         if (dtl_check_mtime($skinpath, $z)) {
  90.             if (defined $PARAMS->{templates}->{$skininit}) {
  91.                 return 1 if $skip;
  92.                 my $varname = join('::', $PARAMS->{templates}->{$skininit}, 'process');
  93.                 $substitutions = (&{\&{$varname}}($substitutions))[1];
  94.             } elsif (-e "$d/$skininit.pl" && require "$d/$skininit.pl") {
  95.                 $PARAMS->{templates}->{$skininit} = $skininit;
  96.                 return 1 if $skip;
  97.                 my $varname = join('::', $PARAMS->{templates}->{$skininit}, 'process');
  98.                 $substitutions = (&{\&{$varname}}($substitutions))[1];
  99.             }
  100.             if (-e $z && require "$z") {
  101.                 performance_string("* Using cached skin for $filename");
  102.                 $PARAMS->{templates}->{$filename} = $filename;
  103.                 return 1 if $skip;
  104.                 my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
  105.                 return &{\&{$varname}}($substitutions);
  106.             } else {
  107.                 unlink $z;
  108.             }
  109.         }
  110.         my @parts = ();
  111.         if (open (SKIN, "< $skinpath")) {
  112.             my @skin = <SKIN>;
  113.             close (SKIN);
  114.             my @z = ();
  115.             my $flag = "";
  116.             foreach my $line (@skin) {
  117.                 if ($line =~ m|^\s*<#part "([^"]+)"#>\s*$|i) {
  118.                     $flag = $1; $flag =~ s/\W/_/g;
  119.                     push @z, "<!--BEGIN-->\n";
  120.                 } elsif ($line =~ m|^\s*<#/part#>\s*$|i) {
  121.                     push @z, "<!--END-->\n";
  122.                     my @t = @z;
  123.                     push @parts, { part => $flag, content => \@t };
  124.                     $flag = "";
  125.                     @z = ();
  126.                 } elsif ($flag ne "") {
  127.                     push @z, $line;
  128.                 }
  129.             }
  130.             my $prefix = $topic == 0 ? "SKIN_" : join("", "SKIN_", $topic, "_");
  131.             dreq("templint");
  132.             foreach my $file (@parts) {
  133.                 my $z = join("", $prefix, $file->{part});
  134.                 my @fileout = dtlperl($z, @{$file->{content}});
  135.                 open (FILEOUT, "> $DCONF->{admin_dir}/data/tcache/$z.pl");
  136.                 print FILEOUT @fileout;
  137.                 close (FILEOUT);
  138.                 chmod oct($DCONF->{perms0666}), "$DCONF->{admin_dir}/data/tcache/$z.pl";
  139.             }
  140.             if (defined $PARAMS->{templates}->{$skininit}) {
  141.                 return 1 if $skip;
  142.                 my $varname = join('::', $PARAMS->{templates}->{$skininit}, 'process');
  143.                 $substitutions = (&{\&{$varname}}($substitutions))[1];
  144.             } elsif (-e "$d/$skininit.pl" && require "$d/$skininit.pl") {
  145.                 $PARAMS->{templates}->{$skininit} = $skininit;
  146.                 return 1 if $skip;
  147.                 my $varname = join('::', $PARAMS->{templates}->{$skininit}, 'process');
  148.                 $substitutions = (&{\&{$varname}}($substitutions))[1];
  149.             }
  150.             if (defined $PARAMS->{templates}->{$filename}) {
  151.                 return 1 if $skip;
  152.                 my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
  153.                 return &{\&{$varname}}($substitutions);
  154.             } elsif (-e "$DCONF->{admin_dir}/data/tcache/$filename.pl" && require "$DCONF->{admin_dir}/data/tcache/$filename.pl") {
  155.                 $PARAMS->{templates}->{$filename} = $filename;
  156.                 return 1 if $skip;
  157.                 my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
  158.                 return &{\&{$varname}}($substitutions);
  159.             } else {
  160.                 unlink "$DCONF->{admin_dir}/data/tcache/$filename.pl";
  161.                 my @str = ("Failed skin require on $filename: $!");
  162.                 my $i = 0;
  163.                 while (my ($pack, $file, $line, $subname, $hasargs, $wantarray) = caller($i++)) {
  164.                       $file = $' if $file =~ /.*[\\\/]/;
  165.                       push @str, "$file :: $line :: $subname";
  166.                   }
  167.                   template_error(@str);
  168.             }
  169.         } else {
  170.             template_error("Skin Open Error", "Could not open skin $skinpath!", $!);
  171.         }
  172.     }
  173. }
  174.  
  175. ###
  176. ### dtl_check_mtime
  177. ###
  178. ### Checks modification times on templates, results, and this script itself
  179. ### to determine whether to force the template to be re-interpreted
  180. ###
  181.  
  182. sub dtl_check_mtime {
  183.     my ($template_path, $interpreted_path) = @_;
  184.     return 1 if $PARAMS->{'dtl_check_mtime'}->{$template_path} == 1;
  185.     return 0 if ! -e $interpreted_path;
  186.     if ($PARAMS->{mtime}->{'templint.pl'} == 0) {
  187.         $PARAMS->{mtime}->{'templint.pl'} = (stat "$DCONF->{admin_dir}/source/templint.pl")[9];
  188.     }
  189.     if ($PARAMS->{mtime}->{$template_path} == 0) {
  190.         $PARAMS->{mtime}->{$template_path} = (stat $template_path)[9];
  191.     }
  192.     if ($PARAMS->{mtime}->{$interpreted_path} == 0) {
  193.         $PARAMS->{mtime}->{$interpreted_path} = (stat $interpreted_path)[9];
  194.     }
  195.     return 0 if $PARAMS->{mtime}->{'templint.pl'} > $PARAMS->{mtime}->{$interpreted_path};
  196.     return 0 if $PARAMS->{mtime}->{$template_path} > $PARAMS->{mtime}->{$interpreted_path};
  197.     $PARAMS->{'dtl_check_mtime'}->{$template_path} = 1;
  198.     return 1;
  199. }
  200.  
  201. ###
  202. ### dtl_grab_skin
  203. ###
  204. ### Gives the full path for the appropriate customized skin file for a topic
  205. ###
  206.  
  207. sub dtl_grab_skin {
  208.     my ($topic) = @_;
  209.     return $PARAMS->{'dtl_grab_skin'}->{$topic} if defined $PARAMS->{'dtl_grab_skin'}->{$topic};
  210.     if ($topic > 0) {
  211.         if ($DCONF->{"registered_skin_$topic"} ne "") {
  212.             my $filepath = $DCONF->{"registered_skin_$topic"};
  213.             if (-e $filepath && -r $filepath) {
  214.                 $PARAMS->{'dtl_grab_skin'}->{$topic} = $filepath;
  215.                 return $filepath;
  216.             }
  217.         }
  218.         my $path = get_message_path($topic);
  219.         if (-e "$path/default.tmpl" && -r "$path/default.tmpl") {
  220.             $PARAMS->{'dtl_grab_skin'}->{$topic} = "$path/default.tmpl";
  221.             return "$path/default.tmpl";
  222.         }
  223.     }
  224.     my $default = "$DCONF->{admin_dir}/skins/$GLOBAL_OPTIONS->{'skinchoice'}.tmpl";
  225.     $PARAMS->{'dtl_grab_skin'}->{$topic} = $default;
  226.     return $default if -e $default && -r $default;
  227.     template_error("Skin Error", "Could not find valid skin for topic $topic (skin choice: $GLOBAL_OPTIONS->{skinchoice})");
  228. }
  229.  
  230. ###
  231. ### template_includer
  232. ###
  233. ### For including a template within a file
  234. ###
  235.  
  236. sub template_includer {
  237.     my ($templatename, $substitutions) = @_;
  238.     $PARAMS->{template_includer_counter} += 1;
  239.     template_error("Recursive condition detected inserting $templatename") if $PARAMS->{template_includer_counter} > 50;
  240.     my $z = dtl_interpret_template($templatename, $substitutions);
  241.     $PARAMS->{template_includer_counter} -= 1;
  242.     return join("", $z, "\n");
  243. }
  244.  
  245. ###
  246. ### getgmtoffset
  247. ###
  248. ### Calculates GMT offset for <#gmtoffset#> command code
  249. ###
  250.  
  251. sub getgmtoffset {
  252.     my $time = time;
  253.     my ($s1, $m1, $hr1, $mo1, $dy1, $yr1) = localtime($time);
  254.     my ($s2, $m2, $hr2, $mo2, $dy2, $yr2) = gmtime($time);
  255.     my $offset = ($s1 - $s2);
  256.     $offset += 60 * ($m1 - $m2);
  257.     $offset += 60 * 60 * ($hr1 - $hr2);
  258.     $offset += 24 * 60 * 60 if ($mo1 > $mo2);
  259.     $offset -= 24 * 60 * 60 if ($mo1 < $mo2);
  260.     $offset += 24 * 60 * 60 if ($mo1 == $mo2 && $dy1 > $dy2);
  261.     $offset -= 24 * 60 * 60 if ($mo1 == $mo2 && $dy1 < $dy2);
  262.     return $offset;
  263. }
  264.  
  265. ###
  266. ### dtl_interpret_template
  267. ###
  268. ### Template interpreter
  269. ###
  270.  
  271. sub dtl_interpret_template {
  272.     my ($filename, $substitutions, $skip) = @_;
  273.     if (! defined $substitutions->{'_ALTCOLOR'}) {
  274.         $substitutions = basic_substitutions($substitutions);
  275.     }
  276.     if (! defined $substitutions->{'color_override'}) {
  277.         $substitutions = color_substitutions($substitutions);
  278.     }
  279.     if (defined $PARAMS->{templates}->{$filename}) {
  280.         my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
  281.         return (&{\&{$varname}}($substitutions))[0];
  282.     } else {
  283.         if (! -e "$DCONF->{admin_dir}/data/tcache") {
  284.             if (mkdir "$DCONF->{admin_dir}/data/tcache", oct($DCONF->{perms0777})) {
  285.                 chmod oct($DCONF->{perms0777}), "$DCONF->{admin_dir}/data/tcache";
  286.             } else {
  287.                 barf_tcache($!);
  288.             }
  289.         }
  290.         my $fn = $filename; $fn =~ s/\W/_/g;
  291.         my @dirs = map { join("/", $DCONF->{admin_dir}, "template", $_) } ('custom', 'pro', 'admin', 'ui', 'mailmesg');
  292.         my $actual_path = "";
  293.         if (-e "$DCONF->{admin_dir}/data/tcache/$fn.pl") {
  294.             foreach my $z (@dirs) {
  295.                 if (-e "$z/$filename.tmpl") {
  296.                     $actual_path = "$z/$filename.tmpl";
  297.                     @dirs = ($z);
  298.                     last;
  299.                 }
  300.             }
  301.             if (dtl_check_mtime($actual_path, "$DCONF->{admin_dir}/data/tcache/$fn.pl")) {
  302.                 if (require "$DCONF->{admin_dir}/data/tcache/$fn.pl") {
  303.                     $PARAMS->{templates}->{$filename} = $fn;
  304.                     return 1 if $skip;
  305.                     performance_string("* Using cached template for $fn");
  306.                     my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
  307.                     return (&{\&{$varname}}($substitutions))[0];
  308.                 } else {
  309.                     unlink "$DCONF->{admin_dir}/data/tcache/$fn.pl";
  310.                 }
  311.             } else {
  312.                 unlink "$DCONF->{admin_dir}/data/tcache/$fn.pl";
  313.             }
  314.         }
  315.         foreach my $dir (@dirs) {
  316.             if ($actual_path ne "" || -e "$dir/$filename.tmpl") {
  317.                 open (FILEOPEN, "< $dir/$filename.tmpl");
  318.                 my @file = <FILEOPEN>;
  319.                 close (FILEOPEN);
  320.                 my $fn = $filename; $fn =~ s/\W/_/g;
  321.                 dreq("templint");
  322.                 my @fileout = dtlperl($fn, @file);
  323.                 if (open (FILEOUT, "> $DCONF->{admin_dir}/data/tcache/$fn.pl")) {
  324.                     print FILEOUT @fileout;
  325.                     close (FILEOUT);
  326.                 } else {
  327.                     template_error("Could not write to template cache directory 'tcache' file '$fn.pl': $!");
  328.                 }
  329.                 chmod oct($DCONF->{perms0666}), "$DCONF->{admin_dir}/data/tcache/$fn.pl";
  330.                 if (require "$DCONF->{admin_dir}/data/tcache/$fn.pl") {
  331.                     $PARAMS->{templates}->{$filename} = $fn;
  332.                     return 1 if $skip;
  333.                     my $varname = join('::', $PARAMS->{templates}->{$filename}, 'process');
  334.                     return (&{\&{$varname}}($substitutions))[0];
  335.                 } else {
  336.                     unlink "$DCONF->{admin_dir}/data/tcache/$fn.pl";
  337.                     my @str = ("Failed template require on $filename: $!");
  338.                     my $i = 0;
  339.                     while (my ($pack, $file, $line, $subname, $hasargs, $wantarray) = caller($i++)) {
  340.                           $file = $' if $file =~ /.*[\\\/]/;
  341.                            push @str, "$file :: $line :: $subname";
  342.                        }
  343.                        template_error(@str);
  344.                    }
  345.             }
  346.         }
  347.     }
  348. }
  349.  
  350. ###
  351. ### barf_tcache
  352. ###
  353. ### Helpful error messages for many Windows customers whose permissions won't
  354. ### be set up right
  355. ###
  356.  
  357. sub barf_tcache {
  358.     my $errcode = shift @_;
  359.     my @msg = ();
  360.     push @msg, "<font color=#ff0000>Directory creation error</font>";
  361.     push @msg, "Discus cannot create a 'tcache' directory under 'data'";
  362.     push @msg, "Reason from operating system is: <u>$errcode</u>";
  363.     push @msg, "For troubleshooting hints on this error message, consult:";
  364.     push @msg, "<a href=\"http://support.discusware.com/center/resources/errors/dce.html\" target=\"_blank\">Directory creation error help</a>";
  365.     template_error(@msg);
  366. }
  367.  
  368. ###
  369. ### does_part_exist
  370. ###
  371. ### Sees if a part of a skin exists (for <#part "xxx" () exists#> code)
  372. ###
  373.  
  374. sub does_part_exist {
  375.     my ($topicnum, $part) = @_;
  376.     my $prefix = $topicnum > 0 ? "SKIN_$topicnum" : "SKIN";
  377.     my $fn = join("", $prefix, "_", $part);
  378.     return 1 if defined $PARAMS->{templates}->{$fn};
  379.     return 1 if -e "$DCONF->{admin_dir}/data/tcache/$fn.pl";
  380.     my $x = join("_", $prefix, "page");
  381.     return 0 if -e "$DCONF->{admin_dir}/data/tcache/$x.pl";
  382.     my $y = dtl_interpret_skin("$topicnum$part", {}, 1);
  383.     return 1 if defined $PARAMS->{templates}->{$fn};
  384.     return 1 if -e "$DCONF->{admin_dir}/data/tcache/$fn.pl";
  385.     return 0;
  386. }
  387.  
  388. ###
  389. ### picker
  390. ###
  391. ### Picks an element of an array (for <#pick ... #> code)
  392. ###
  393.  
  394. sub picker {
  395.     my ($pick, $item_no, $arrayname, $item_choice, $substitutions) = @_;
  396.     if (ref $substitutions->{$arrayname} ne "ARRAY") {
  397.         template_error("Use of undefined array \@$arrayname in pick statement!");
  398.     }
  399.     $item_choice =~ s/\s//g;
  400.     my @item_choose = split(/,/, $item_choice);
  401.     if ($item_choice eq "*") {
  402.         if (scalar(@{ $substitutions->{$arrayname} }) > 0) {
  403.             @item_choose = (1 .. scalar(@{ $substitutions->{$arrayname} }));
  404.         } else {
  405.             template_error("Invalid array '\@$arrayname' does not have any elements!");
  406.         }
  407.     }
  408.     if (scalar(@item_choose) == 0) {
  409.         template_error("Invalid selection index '$item_choice' in pick statement on \@$arrayname!");
  410.     }
  411.     my $arrindex = ($item_no - 1) % scalar(@item_choose);
  412.     template_error("Use of undefined index [ $item_choose[$arrindex] ] for array index $arrindex in item choices ($item_choice)!") unless (@{ $substitutions->{$arrayname} })[ $item_choose[$arrindex] - 1 ];
  413.     my $text = ( (@{ $substitutions->{$arrayname} })[ $item_choose[$arrindex] - 1 ])->{$pick};
  414.     return $text;
  415. }
  416.  
  417. ###
  418. ### skin_includer
  419. ###
  420. ### For including a part of a skin within the currently executing skin or template
  421. ###
  422.  
  423. sub skin_includer {
  424.     my ($topic, $part, $substitutions) = @_;
  425.     $topic = "" if $topic !~ /^\d+$/;
  426.     return dtl_interpret_skin("$topic$part", $substitutions);
  427. }
  428.  
  429. ###
  430. ### case_u
  431. ###
  432. ### Capitalizes the first letter of a string
  433. ###
  434.  
  435. sub case_u {
  436.     my ($text) = @_;
  437.     return "" if length($text) eq "";
  438.     return join("", uc(substr($text, 0, 1)), substr($text, 1, length($text)-1));
  439. }
  440.  
  441. ###
  442. ### case_l
  443. ###
  444. ### Lower-cases the first letter of a string
  445. ###
  446.  
  447. sub case_l {
  448.     my ($text) = @_;
  449.     return "" if length($text) eq "";
  450.     return join("", lc(substr($text, 0, 1)), substr($text, 1, length($text)-1));
  451. }
  452.  
  453. ###
  454. ### file_includer
  455. ###
  456. ### Includes a file from the file system into a template
  457. ###
  458.  
  459. sub file_includer {
  460.     my ($filename, $px) = @_;
  461.     return "" if $PARAMS->{cache}->{notfound}->{$filename};
  462.     $px =~ s/\s+/,/g;
  463.     my %hashref = map { $_, 1 } split(/,/, $px);
  464.     if (-f $filename && -r $filename) {
  465.         my $text = "";
  466.         my $flag = 0;
  467.         open(FILE, "< $filename");
  468.         while (<FILE>) {
  469.             s%<IMG SRC="icons/%<IMG SRC="$DCONF->{html_url}/$DCONF->{icon_dir}/%gi;
  470.             s%<IMG SRC="$DCONF->{icon_dir}/%<IMG SRC="$DCONF->{html_url}/$DCONF->{icon_dir}/%gi;
  471.             if ($hashref{'BODY'} && m|^<BODY|) {
  472.                 $flag = 1;
  473.             } elsif ($hashref{'BODY'} && $flag) {
  474.                 $text .= $_;
  475.             } elsif ($hashref{'BODY'} && !$flag) {
  476.                 next;
  477.             } else {
  478.                 $text .= $_;
  479.             }
  480.         }
  481.         close (FILE);
  482.         return $text;
  483.     } else {
  484.         $PARAMS->{cache}->{notfound}->{$filename} = 1;
  485.         template_error("Failed to open required file to generate this portion of the display.") if $hashref{'FATAL'};
  486.         return "";
  487.     }
  488. }
  489.  
  490. ###
  491. ### reference_array_from
  492. ###
  493. ### Handles <#reference array ... #> code
  494. ###
  495.  
  496. sub reference_array_from {
  497.     my ($arrayname, $arrayfrom, $field, $except, $substitutions) = @_;
  498.     my %e = map { trim($_), 1 } split(/,/, trim($except));
  499.     $field = trim($field);
  500.     my @z = ();
  501.     if (ref $arrayfrom eq 'ARRAY') {
  502.         if ($field eq '') {
  503.             @z = @{ $arrayfrom };
  504.         } else {
  505.             @z = grep { $e{$_->{$field}} == 0 } @{$arrayfrom};
  506.         }
  507.     }
  508.     $substitutions->{$arrayname} = \@z;
  509.     return $substitutions;
  510. }
  511.  
  512. 1;
  513.