home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / FAQ / discus_admin_1357211388 / source / common.pl < prev    next >
Text File  |  2009-11-06  |  77KB  |  2,386 lines
  1. # FILE: common.pl
  2. # DESCRIPTION: Common subroutines and procedures
  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 $PARAMS $DCONF);
  17.  
  18. #-------------------------------------------------------------------------------
  19. # DEFINE PARAMETERS
  20.  
  21. undef $PARAMS;
  22. $PARAMS->{'release'} = "4.00"; $PARAMS->{'revision'} = "9";
  23. $PARAMS->{'serial'} = join("", ($DCONF->{pro} ? "1" : "0"), ".04.00.066");
  24. $PARAMS->{'date'} = "04/07/2006";
  25.  
  26. #-------------------------------------------------------------------------------
  27. # OTHER PARAMETERS, FOR CONVENIENCE & BACKWARD COMPATIBILITY
  28.  
  29. $PARAMS->{'url_to_default_image'} = "$DCONF->{'html_url'}/clipart/your_image.gif";
  30. $PARAMS->{'cgiurl'} = "$DCONF->{'script_url'}/board-admin.$DCONF->{'cgi_extension'}";
  31. $PARAMS->{'already_printed_header'} = 0;
  32. $PARAMS->{'do_not_write_files'} = (-e "$DCONF->{admin_dir}/backups/QUOTA.txt");
  33. $PARAMS->{'fs'} = '<font face="verdana,arial,helvetica" size="2">';
  34. $PARAMS->{'files_locked_list'} = {};
  35. $PARAMS->{'emergency_access'} = -f "$DCONF->{admin_dir}/data/emergency.txt";
  36.  
  37. #-------------------------------------------------------------------------------
  38. # AMEND DISCUS.CONF PARAMETERS IF NOT ALREADY DEFINED
  39.  
  40. $DCONF->{'board_topics_file'} = "board-topics.html" if $DCONF->{'board_topics_file'} eq "";
  41. $DCONF->{'perms0777'} = "0777" if $DCONF->{'perms0777'} eq "";
  42. $DCONF->{'perms0666'} = "0666" if $DCONF->{'perms0666'} eq "";
  43. $DCONF->{'perms0644'} = "0644" if $DCONF->{'perms0644'} eq "";
  44. $DCONF->{'message_dir'} = "$DCONF->{html_dir}/messages" if $DCONF->{'message_dir'} eq "";
  45. $DCONF->{'message_url'} = "$DCONF->{html_url}/messages" if $DCONF->{'message_url'} eq "";
  46. $DCONF->{'secdir'} = "$DCONF->{admin_dir}/secure" if $DCONF->{'secdir'} eq "";
  47. $DCONF->{'icon_dir'} = "icons" if $DCONF->{'icon_dir'} eq "";
  48. $PARAMS->{'icon_url'} = defined $DCONF->{icon_url} ? $DCONF->{icon_url} : join("/", $DCONF->{html_url}, $DCONF->{icon_dir});
  49. $DCONF->{'mail_charset'} = "us-ascii" if $DCONF->{mail_charset} eq "";
  50. $DCONF->{'authorize_reader'} = "$DCONF->{script_url}/board-auth.$DCONF->{cgi_extension}" if ! defined $DCONF->{authorize_reader};
  51.  
  52. #-------------------------------------------------------------------------------
  53. # CUSTOMIZED OR USER-INSTALLED PERL MODULES
  54.  
  55. unshift @INC, "$DCONF->{admin_dir}/perlpkgs" if ! defined $DCONF->{perl_package_dir};
  56. unshift @INC, $DCONF->{perl_package_dir} if defined $DCONF->{perl_package_dir};
  57.  
  58. #-------------------------------------------------------------------------------
  59. # RANDOM NUMBER SEED
  60.  
  61. srand(time);
  62.  
  63. #-------------------------------------------------------------------------------
  64. # READ IN GLOBAL OPTIONS
  65.  
  66. if (! $DCONF->{no_read_options}) {
  67.     undef $GLOBAL_OPTIONS;
  68.     if (open (OPT, "$DCONF->{admin_dir}/options.txt")) {
  69.         while (<OPT>) {
  70.             $GLOBAL_OPTIONS->{$1} = unescape($2) if m|^(\w+)=(.*?)\s*$|;
  71.         }
  72.         close (OPT);
  73.         if ($GLOBAL_OPTIONS->{enable_debugging}) {
  74.             dreq("prgdebug");
  75.             $GLOBAL_OPTIONS->{enable_debugging_user_hash} = program_debug_get_debugging_users($GLOBAL_OPTIONS->{debug_users});
  76.         }
  77.         $GLOBAL_OPTIONS->{'skinchoice'} = "tables2" if $GLOBAL_OPTIONS->{'skinchoice'} eq "";
  78.     }
  79. }
  80.  
  81. #-------------------------------------------------------------------------------
  82. # PERFORMANCE MONITORING (IF ENABLED, MAINLY FOR DEBUGGING PURPOSES)
  83.  
  84. if ($GLOBAL_OPTIONS->{discus_taskman} == 0 && $GLOBAL_OPTIONS->{performance_monitoring} > 0) {
  85.     my $pfm = $GLOBAL_OPTIONS->{performance_monitoring} == 1 ? ">" : ">>";
  86.     if (open (PERFORMANCE_MONITOR, "$pfm $DCONF->{admin_dir}/data/performance.txt")) {
  87.         performance_string("-" x 60);
  88.         performance_string("Invoking at ", scalar(localtime(time)));
  89.         performance_string("Opening $0");
  90.         $PARAMS->{files_read} = 0;
  91.         $PARAMS->{files_written} = 0;
  92.         $PARAMS->{files_locked} = 0;
  93.         $PARAMS->{files_unlocked} = 0;
  94.         $PARAMS->{file_access} = {};
  95.     }
  96. }
  97.  
  98. #-------------------------------------------------------------------------------
  99. # LIMIT SIMULTANEOUS ACCESSES BY YOUR GUESTS (PRO ONLY, IF CONFIGURED)
  100.  
  101. if ($DCONF->{pro} && $GLOBAL_OPTIONS->{limit_simultaneous_access_on} && $GLOBAL_OPTIONS->{limit_simultaneous_access} >= 1) {
  102.     dreq("lim-accs-PRO");
  103.     if (! limit_access_ok($ENV{'REMOTE_ADDR'})) {
  104.         sleep 5;
  105.         error_message("Access is Denied", "Host $ENV{'REMOTE_ADDR'} has accessed this page too often.", 0, 1);
  106.     }
  107. }
  108.  
  109. #-------------------------------------------------------------------------------
  110. # START/CHECK DISCUS TASK MANAGER DAEMON
  111.  
  112. if ($GLOBAL_OPTIONS->{discus_taskman} == 1) {
  113.     dreq("dtaskman"); taskman_init();
  114. }
  115.  
  116. #-------------------------------------------------------------------------------
  117. # IP BANNING (PRO ONLY)
  118.  
  119. if ($DCONF->{pro}) {
  120.     dreq("bannedip-PRO");
  121.     check_banned_ip($ENV{REMOTE_ADDR}, $ENV{REMOTE_HOST});
  122. }
  123.  
  124. #-------------------------------------------------------------------------------
  125. # DEFINE SUBROUTINES
  126.  
  127. ###
  128. ### database_dbh
  129. ###
  130. ### As needed, in database mode, connect to database
  131. ###
  132.  
  133. sub database_dbh {
  134.     return undef if $GLOBAL_OPTIONS->{database} == 0;
  135.     return $PARAMS->{dbh} if defined $PARAMS->{dbh};
  136.     dreq("dbint");
  137.     $PARAMS->{dbh} = (db_connect(1))[0];
  138.     return $PARAMS->{dbh};
  139. }
  140.  
  141. ###
  142. ### program_exit
  143. ###
  144. ### Replaces the "exit" function of Perl so that any necessary subroutines
  145. ### are called before you exit.
  146. ###
  147.  
  148. sub program_exit {
  149.     my $status = shift;
  150.     access_completed($ENV{'REMOTE_ADDR'}) if ($DCONF->{pro} && $GLOBAL_OPTIONS->{limit_simultaneous_access_on} && $GLOBAL_OPTIONS->{limit_simultaneous_access} >= 1);
  151.     if (defined $PARAMS->{token_file}) {
  152.         acs_write_token_file(undef, $PARAMS->{token_file}, { force_write => 1 });
  153.     }
  154.     if ($GLOBAL_OPTIONS->{performance_monitoring}) {
  155.         performance_string("Closing via program_exit($status)");
  156.         performance_string_dump();
  157.         close (PERFORMANCE_MONITOR);
  158.         chmod(oct($DCONF->{perms0666}), "$DCONF->{admin_dir}/data/performance.txt");
  159.         unlock ("$DCONF->{admin_dir}/data/performance.txt");
  160.     }
  161.     if (defined $PARAMS->{dbh}) {
  162.          if (! $PARAMS->{dbh}->disconnect()) {
  163.              log_error("common.pl", "program_exit", join("", "Could not disconnect from database: ", $PARAMS->{dbh}->errstr()));
  164.         }
  165.     }
  166.     if ($PARAMS->{debugging_on}) {
  167.         program_debug_close();
  168.     }
  169.     exit($status);
  170. }
  171.  
  172. ###
  173. ### performance_string_dump
  174. ###
  175. ### Writes statistics to performance monitoring file
  176. ###
  177.  
  178. sub performance_string_dump {
  179.     my ($identifier) = @_;
  180.     performance_string("-" x 60);
  181.     performance_string("Performance data for $identifier") if $identifier;
  182.     performance_string(join("\t", times));
  183.     performance_string("$PARAMS->{files_read} file(s) read, $PARAMS->{files_written} file(s) written");
  184.     performance_string("$PARAMS->{files_locked} file(s) locked, $PARAMS->{files_unlocked} file(s) unlocked");
  185.     foreach my $k (keys(%{ $PARAMS->{file_access} })) {
  186.         performance_string("   * $PARAMS->{file_access}->{$k}->{read} read(s), $PARAMS->{file_access}->{$k}->{write} writes(s) on $k");
  187.     }
  188.     performance_string("-" x 60);
  189. }
  190.  
  191. ###
  192. ### performance_string
  193. ###
  194. ### Writes out a string in performance monitoring
  195. ###
  196.  
  197. sub performance_string {
  198.     return undef if ! $GLOBAL_OPTIONS->{performance_monitoring};
  199.     my $string = join("", @_);
  200.     my ($sec, $min, $hour, $day, $nmonth, $year) = localtime(time);
  201.     my $dt = sprintf("%04d-%02d-%02d %02d:%02d:%02d", 1900+$year, 1+$nmonth, $day, $hour, $min, $sec);
  202.     print PERFORMANCE_MONITOR "$dt $$ $ENV{REMOTE_ADDR} $string\n";
  203.     if (0) {
  204.         if (ref $PARAMS->{lockfiles} eq 'HASH' && scalar keys %{$PARAMS->{lockfiles}} > 0) {
  205.             foreach my $x (keys %{$PARAMS->{lockfiles}}) {
  206.                 print PERFORMANCE_MONITOR "\tLocked: $x\n";
  207.             }
  208.         }
  209.     }
  210. }
  211.  
  212. ###
  213. ### cookie_string_format
  214. ###
  215. ### Generates a string to set a cookie
  216. ###
  217.  
  218. sub cookie_string_format {
  219.     my ($cookie_name, $cookie_value, $expiration) = @_;
  220.     my $str = join("", "Set-Cookie: $cookie_name$DCONF->{COOKIE_ID}=", escape($cookie_value), ";");
  221.     $str .= " expires=$expiration;" if $expiration ne "";
  222.     $str .= " path=/\n";
  223.     return $str;
  224. }
  225.  
  226. ###
  227. ### directory_list
  228. ###
  229. ### Lists all files in a directory
  230. ###
  231.  
  232. sub directory_list {
  233.     my ($basedir, $pat, $no_incl_basedir) = @_;
  234.     my @o = ();
  235.     if (opendir(DIR, $basedir)) {
  236.         @o = map {"$basedir/$_"} grep {not /^\.\.?$/} readdir DIR if ! $no_incl_basedir;
  237.         @o = map {$_} grep {not /^\.\.?$/} readdir DIR if $no_incl_basedir;
  238.         closedir(DIR);
  239.         @o = grep(/$pat/, @o) if defined $pat;
  240.     }
  241.     return \@o;
  242. }
  243.  
  244. ###
  245. ### get_message_path
  246. ###
  247. ### Gets path to message directory for a particular topic
  248. ###
  249.  
  250. sub get_message_path {
  251.     my ($topic) = @_;
  252.     return $PARAMS->{topic_message_path}->{$topic} if defined $PARAMS->{topic_message_path}->{$topic};
  253.     my $in_topic = $topic; $topic =~ s/\D//g;
  254.     error_message("Topic Format Error", "Invalid topic request [$in_topic]!", 0, 1) if $topic eq "";
  255.     return join("/", $DCONF->{message_dir}, $topic) if ! $DCONF->{pro};
  256.     if (-e "$DCONF->{secdir}/$topic") {
  257.         $PARAMS->{topic_message_path}->{$topic} = join("/", $DCONF->{secdir}, $topic);
  258.     } else {
  259.         $PARAMS->{topic_message_path}->{$topic} = join("/", $DCONF->{message_dir}, $topic);
  260.     }
  261.     return $PARAMS->{topic_message_path}->{$topic};
  262. }
  263.  
  264. ###
  265. ### attachment_scan
  266. ###
  267. ### Finds what attachments are present within messages
  268. ###
  269.  
  270. sub attachment_scan {
  271.     my ($message_in) = @_;
  272.     my @m = ref $message_in eq 'ARRAY' ? @{$message_in} : ($message_in);
  273.     my @att = ();
  274.     my $murl = quotemeta($DCONF->{message_url});
  275.     my $hurl = quotemeta($DCONF->{html_url});
  276.     $murl =~ s%\\/%\\/\+%g;
  277.     $hurl =~ s%\\/%\\/\+%g;
  278.     my $ctr = -1;
  279.     foreach my $msg (@m) {
  280.         $ctr++;
  281.         my $text = ref $msg eq 'HASH' ? $msg->{text} : $msg;
  282.         my $postnum = ref $msg eq 'HASH' ? $msg->{number} : 0;
  283.         # Version 3.10/4.00 GIFs and JPEGs
  284.         while ($text =~ m%<IMG SRC="$murl/+(\d+)/(\d+)\.(gif|jpg)" ALT="(.*?)"%gi) {
  285.             push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('.',$2,$3), mime => join("/", 'image', $3 eq "gif" ? $3 : "jpeg"), descr => $4 };
  286.         }
  287.         # Version 3.10/4.00 PNGs
  288.         while ($text =~ m%<IMG SRC="$murl/+(\d+)/(\d+)\.(png)" ALT="(.*?)"%gi) {
  289.             push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('.',$2,$3), mime => "image/x-png", descr => $4 };
  290.         }
  291.         # Thumbnailed version 4.00 GIFs and JPEGs
  292.         while ($text =~ m%<IMG SRC="$murl/+(\d+)/(\d+)t\.(gif|jpg)" ALT="(.*?)"%gi) {
  293.             push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('.',$2,$3), mime => join("/", 'image', $3 eq "gif" ? $3 : "jpeg"), descr => $4 };
  294.             push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('',$2,"t.",$3), mime => join("/", 'image', $3 eq "gif" ? $3 : "jpeg"), descr => $4 };
  295.         }
  296.         # Thumbnailed version 4.00 PNGs
  297.         while ($text =~ m%<IMG SRC="$murl/+(\d+)/(\d+)t\.(png)" ALT="(.*?)"%gi) {
  298.             push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('.',$2,$3), mime => "image/x-png", descr => $4 };
  299.             push @att, { counter => $ctr, postnum => $postnum, type => 'image', filename => join('',$2,"t.",$3), mime => "image/x-png", descr => $4 };
  300.         }
  301.         # Version 3.10 Attachments
  302.         my $icdir = $DCONF->{icon_dir};
  303.         while ($text =~ m%<!-attachment: (.*?)-!><center><table border=1><tr><td><img src="$hurl/+$icdir/(.*?)" align=left alt="(.*?)">(.*?)<br><a href="$murl/+(\d+)/\1"><b>(.*?)</b></a> \((.*?) k\)</td></tr></table></center><!-/attachment-!>%gi) {
  304.             push @att, { counter => $ctr, postnum => $postnum, type => 'attach', filename => $1, mime => $3, showfile => $6, size => $7, descr => $4, icon => $2 };
  305.         }
  306.         # Version 4.00 Attachments
  307.         while ($text =~ m%<!--attachment: (.*?)\*(.*?)\*(.*?)\*(.*?)\*(.*?)\*(.*?) -->%gi) {
  308.             push @att, { counter => $ctr, postnum => $postnum, type => 'attach', filename => $1, icon => $2, mime => $3, size => $4, descr => unescape($5), showfile => unescape($6) };
  309.         }
  310.     }
  311.     return \@att;
  312. }
  313.  
  314. ###
  315. ### discus
  316. ###
  317. ### This runs Discus, based on the file name of the script calling.
  318. ###
  319.  
  320. sub discus {
  321.     my ($s, $FORMref, $cookie_str) = @_;
  322.     $s = determine_script_name($s);
  323.     $PARAMS->{calling_script} = $s;
  324.     if ($s eq "board-viewtree") {
  325.         maintenance_mode_error() if $GLOBAL_OPTIONS->{maintenance};
  326.         dreq("treeview"); tree_control($FORMref, $cookie_str);
  327.     }
  328.     if ($s eq "board-post-form") {
  329.         dreq("posting"); posting_control({ action => 'form' });
  330.     }
  331.     if ($s eq "board-post") {
  332.         dreq("posting"); posting_control(undef, $FORMref, $cookie_str);
  333.     }
  334.     if ($s =~ m|^board-admin| || $s eq "admin") {
  335.         dreq("admin-pl"); admin_control();
  336.     }
  337.     if ($s eq "board-auth") {
  338.         error_message(read_language()->{FEATURE_NOT_SUPPORTED}, read_language()->{FEATURE_NOT_SUPPORTED_DESCR}) if ! $DCONF->{pro};
  339.         dreq("authwrap-PRO"); auth_wrapper();
  340.     }
  341.     if ($s eq "board-profile") {
  342.         dreq("ui-prfle"); user_interface_profile_control();
  343.     }
  344.     if ($s eq "discus" || $s eq "show") {
  345.         dreq("ui-main"); user_interface_main_control();
  346.     }
  347.     if ($s eq "board-newmessages" || $s eq "board-search" || $s eq "search") {
  348.         maintenance_mode_error() if $GLOBAL_OPTIONS->{maintenance};
  349.         dreq("search"); search_control($FORMref, $cookie_str);
  350.     }
  351.     if ($s eq "board-contact") {
  352.         dreq("contact"); contact_control();
  353.     }
  354.     if ($s eq "board-image-lister") {
  355.         maintenance_mode_error() if $GLOBAL_OPTIONS->{maintenance};
  356.         dreq("img-list"); image_lister_control();
  357.     }
  358.     if ($s eq "allusers") {
  359.         error_message(read_language()->{FEATURE_NOT_SUPPORTED}, read_language()->{FEATURE_NOT_SUPPORTED_DESCR}) if ! $DCONF->{pro};
  360.         maintenance_mode_error() if $GLOBAL_OPTIONS->{maintenance};
  361.         dreq("allusers-PRO"); user_list_control($FORMref, $cookie_str);
  362.     }
  363.     if ($s eq "reply-email") {
  364.         program_exit(0) if $GLOBAL_OPTIONS->{maintenance};
  365.         dreq("em-reply"); reply_pipe_input();
  366.     }
  367.     if ($s eq "cron-email") {
  368.         program_exit(0) if $GLOBAL_OPTIONS->{maintenance};
  369.         dreq("cronhook"); hook_manager();
  370.     }
  371.     if ($s eq "diagnose") {
  372.         dreq("diags"); diags();
  373.     }
  374.     error_message("Invalid Script", "Script <b>$s</b> does not have an action associated with it, or execution failed.", 0, 1);
  375. }
  376.  
  377. sub determine_script_name {
  378.     my $s = case_lower($_[0]);
  379.     $s = $2 if $s =~ m|^(.*)[\\/](.*)|;
  380.     $s = $` if $s =~ m|\.|;
  381.     return $s if $s =~ /^[\w\-]+$/;
  382.     my @envs = ('SCRIPT_FILENAME', 'REQUEST_URI', 'SCRIPT_NAME', 'DOCUMENT_URI');
  383.     foreach my $e (@envs) {
  384.         next if $ENV{$e} eq "";
  385.         my $s2 = $ENV{$e};
  386.         $s2 = $2 if $s2 =~ m|^(.*)[\\/](.*)|;
  387.         $s2 = $` if $s2 =~ m|\.|;
  388.         return $s2 if $s2 =~ /^[\w\-]+$/;
  389.     }
  390.     return $s;
  391. }
  392.  
  393. ###
  394. ### header
  395. ###
  396. ### Prints the standard header, and the cookie string if needed, and sets $|=1
  397. ### so the server displays any errors more gracefully.  If you have a bizarre
  398. ### server you may need to reverse the "Content-type" line and the $cookie
  399. ### line.
  400. ###
  401.  
  402. sub header {
  403.     my ($cookie, $alternate_mime_type, $content_disposition) = @_;
  404.     return 0 if $PARAMS->{'already_printed_header'};
  405.     if ($cookie ne "") {
  406.         my $c = {};
  407.         my @ckstr = split(/\n/, $cookie);
  408.         foreach my $l (@ckstr) {
  409.             $c->{$1} = $l if $l =~ m|^set-cookie: (\w+)$DCONF->{COOKIE_ID}=|i;
  410.         }
  411.         $cookie = "";
  412.         my $k = 0;
  413.         foreach my $l (keys(%{ $c })) {
  414.             $cookie .= "$c->{$l}\n";
  415.         }
  416.     }
  417.     $PARAMS->{'already_printed_header'} = 1;
  418.     $| = 1;
  419.     print "Content-type: text/html\n" if $alternate_mime_type eq "";
  420.     print "Content-type: $alternate_mime_type\n" if $alternate_mime_type ne "";
  421.     print "Content-disposition: inline; filename=$content_disposition\n" if $content_disposition ne "";
  422.     print $cookie if $cookie ne "";
  423.     print "\n";
  424. }
  425.  
  426. ###
  427. ### read_language
  428. ###
  429. ### Reads the language.conf, language_pro.conf, language_400.conf, etc.,
  430. ### files from the appropriate directories, and stores the result in
  431. ### $PARAMS->{L}.
  432. ###
  433.  
  434. sub read_language {
  435.     my ($topic) = @_;
  436.     return $PARAMS->{L} if defined $PARAMS->{L};
  437.     my $langdir = $DCONF->{admin_dir};
  438.     $langdir = get_message_path($topic) if defined $topic;
  439.     my @lfiles = ('language', 'language_pro', 'lang40');
  440.     my $L = {};
  441.     foreach my $file (@lfiles) {
  442.         undef my @lang;
  443.         if (open(FILE, "$langdir/$file.conf")) {
  444.             @lang = <FILE>;
  445.             close (FILE);
  446.         } elsif (open(FILE, "$DCONF->{admin_dir}/$file.conf")) {
  447.             @lang = <FILE>;
  448.             close (FILE);
  449.         } else {
  450.             next;
  451.         }
  452.         @lang = grep(!/^#/, @lang);
  453.         @lang = grep(/\S/, @lang);
  454.         undef my $cur;
  455.         undef my $del;
  456.         foreach my $line (@lang) {
  457.             $line =~ s/##(.*)//;
  458.             $line =~ s/^\s+//;
  459.             $line =~ s/\s+$//;
  460.             if ($line =~ m|^\$(\w+)|) {
  461.                 $cur = $1; $del = "";
  462.             } elsif ($line =~ m|^\@(\w+)\((.)\)|) {
  463.                 $cur = $1; $del = $2;
  464.             } elsif ($del ne "") {
  465.                 my @arr = split(/$del/, $line);
  466.                 foreach my $a (@arr) {
  467.                     $a =~ s/^\s+//;
  468.                     $a =~ s/\s+$//;
  469.                 }
  470.                 $L->{$cur} = \@arr;
  471.             } elsif ($cur ne "") {
  472.                 $line =~ s/\\\s*$/\n/;
  473.                 $L->{$cur} .= $line . " ";
  474.             }
  475.         }
  476.         foreach my $key (keys(%{$L})) {
  477.             $L->{$key} =~ s/^ +//;
  478.             $L->{$key} =~ s/ +$//;
  479.         }
  480.     }
  481.     $PARAMS->{L} = $L;
  482.     return $L;
  483. }
  484.  
  485. ###
  486. ### dreq
  487. ###
  488. ### Discus REQuire subroutine: reads in required "source" subroutines as needed,
  489. ### but only once.  For some, replacement Discus Pro files are provided, resulting
  490. ### in two possibilities, separated by the |, with the first entry being the file
  491. ### to load for freeware Discus, and the second one the Discus Pro file.
  492. ###
  493.  
  494. sub dreq {
  495.     while (my $file = shift(@_)) {
  496.         if ($file =~ m%^(.*)\|(.*)$%) {
  497.             $file = ($DCONF->{pro} ? $2 : $1);
  498.         }
  499.         next if $PARAMS->{'ALREADY_READ'}->{$file};
  500.         performance_string("\% Reading subroutine: $file");
  501.         if ($file =~ m|-PRO$|) {
  502.             my $path = join("/", $DCONF->{admin_dir}, "source", "PRO_$DCONF->{pro_fileid}", "$`.pl");
  503.             require $path || error_message("Require Error", "Could not require file $file.pl");
  504.         } else {
  505.             require "$DCONF->{admin_dir}/source/$file.pl" || error_message("Require Error", "Could not require file $file.pl");
  506.         }
  507.         $PARAMS->{'ALREADY_READ'}->{$file} = 1;
  508.     }
  509.     return 1;
  510. }
  511.  
  512. ###
  513. ### parse_form
  514. ###
  515. ### Reads in form variables from standard input (POST method) or the URL QUERY_STRING
  516. ### (GET method)
  517. ###
  518.  
  519. sub parse_form {
  520.     my ($query_string, $content_length, $forceform) = @_;
  521.     undef my $FORM;
  522.     my $null = pack("c", 0);
  523.     $content_length = $ENV{CONTENT_LENGTH} if $content_length == 0;
  524.     if ($ENV{CONTENT_TYPE} =~ m|^multipart/form-data|) {
  525.         dreq("fcn-mtp"); $FORM = parse_multipart($content_length);
  526.     } else {
  527.         if ($content_length != 0) {
  528.             binmode(STDIN);
  529.             read(STDIN, my $buffer, $content_length);
  530.             my @pairs = split(/&/, $buffer);
  531.             foreach my $pair (@pairs) {
  532.                 my ($name, $value) = split(/=/, $pair);
  533.                 $value =~ tr/+/ /;
  534.                 $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
  535.                 $value =~ s/<!--#(\w*)(\s*)(\w*)(\s*)=(\s*)"([^"]*)"(.*)-->//g;
  536.                 $value =~ s/\r//g;
  537.                 $value =~ s/$null//g;
  538.                 if ($FORM->{$name} eq "") {
  539.                     $FORM->{$name} = $value;
  540.                 } else {
  541.                     $FORM->{$name} .= ",$value";
  542.                 }
  543.             }
  544.         }
  545.         $query_string =~ s/#(.*)$//;
  546.         if ($query_string ne "") {
  547.             my @query_pairs = split(/&/, $query_string);
  548.             foreach my $qpair (@query_pairs) {
  549.                 my ($qname, $qvalue) = split(/=/, $qpair);
  550.                 $qvalue = unescape($qvalue);
  551.                 $qvalue =~ s/<!--#(\w*)(\s*)(\w*)(\s*)=(\s*)"([^"]*)"(.*)-->//g;
  552.                 $qvalue =~ s/$null//g;
  553.                 $FORM->{$qname} .= ",$qvalue" if $FORM->{$qname} ne "";
  554.                 $FORM->{$qname} = $qvalue if $FORM->{$qname} eq "";
  555.             }
  556.         }
  557.     }
  558.     my $cbuffer = $ENV{'HTTP_COOKIE'};
  559.     if ($ENV{'HTTP_COOKIE'} eq "" && $ENV{'COOKIE'} ne "") {
  560.         $cbuffer = $ENV{'COOKIE'};  #O'Reilly WebSitePro
  561.     }
  562.     my @cpairs = split(/; /, $cbuffer);
  563.     my $ckid = defined $DCONF->{COOKIE_ID} ? quotemeta($DCONF->{COOKIE_ID}) : "";
  564.     foreach my $cpair (@cpairs) {
  565.         my ($cname, $cvalue) = split(/=/, $cpair);
  566.         next if $cname !~ /$ckid$/;
  567.         $cname =~ s/$DCONF->{COOKIE_ID}$//;
  568.         $FORM->{'COOKIE'}->{$cname} = unescape($cvalue);
  569.     }
  570.     if (defined $forceform) {
  571.         foreach my $i (keys(%{ $forceform })) {
  572.             $FORM->{$i} = $forceform->{$i};
  573.         }
  574.     }
  575.     if ($GLOBAL_OPTIONS->{enable_debugging}) {
  576.         dreq("authpass");
  577.         my $user = $FORM->{username};
  578.         $user = $FORM->{COOKIE}->{user} if $user eq "";
  579.         $user = $FORM->{COOKIE}->{admuser} if $user eq "";
  580.         $user = prepare_userpass($user);
  581.         program_debug_invoke($FORM, $user) if $GLOBAL_OPTIONS->{enable_debugging_user_hash}->{$user};
  582.     }
  583.     if ($FORM->{COOKIE}->{access} == 1 && $DCONF->{pro} && $FORM->{pg} ne "logout") {
  584.         if (! $GLOBAL_OPTIONS->{no_banned_user_ban}) {
  585.             dreq("ipaddr-PRO");
  586.             ban_ip_address([{ip => $ENV{REMOTE_ADDR}, reason => read_language()->{BAN_DUE_TO_COOKIE}}]);
  587.         }
  588.         error_message(read_language()->{IP_BANNED}, read_language()->{IP_BANNED_MESSAGE}, 0, 1);
  589.     }
  590.     close (STDIN);
  591.     return $FORM;
  592. }
  593.  
  594. ###
  595. ### escape
  596. ###
  597. ### Quotes strings in standard format
  598. ###
  599.  
  600. sub escape {
  601.     my $i = shift;
  602.     $i =~ s/([^\w ])/sprintf("%%%02lx", ord($1))/eg; $i =~ tr/ /+/;
  603.     return $i;
  604. }
  605.  
  606. ###
  607. ### unescape
  608. ###
  609. ### Inverse of "escape" function
  610. ###
  611.  
  612. sub unescape {
  613.     my $i = shift;
  614.     $i =~ tr/+/ /; $i =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
  615.     return $i;
  616. }
  617.  
  618.  
  619. ###
  620. ### case_equal
  621. ###
  622. ### Sees if two text strings are equal, ignoring case
  623. ###
  624.  
  625. sub case_equal {
  626.     my ($arg1, $arg2) = @_;
  627.     return case_lower($arg1) eq case_lower($arg2);
  628. }
  629.  
  630. ###
  631. ### case_lower
  632. ###
  633. ### Lower-cases a string
  634. ###
  635.  
  636. sub case_lower {
  637.     my ($string) = @_;
  638.     if (defined read_language()->{TBL_CAPS} && defined read_language()->{TBL_SMALL}) {
  639.         my @tbl_1 = split(//, read_language()->{TBL_CAPS});
  640.         my @tbl_2 = split(//, read_language()->{TBL_SMALL});
  641.         while (my $x = shift @tbl_1) {
  642.             if (my $y = shift @tbl_2) {
  643.                 $x = quotemeta($x);
  644.                 $string =~ s/$x/$y/;
  645.             }
  646.         }
  647.         return $string;
  648.     } else {
  649.         return lc($string);
  650.     }
  651. }
  652.  
  653. ###
  654. ### case_upper
  655. ###
  656. ### Upper-cases a string
  657. ###
  658.  
  659. sub case_upper {
  660.     my ($string) = @_;
  661.     if (defined read_language()->{TBL_CAPS} && defined read_language()->{TBL_SMALL}) {
  662.         my @tbl_1 = split(//, read_language()->{TBL_CAPS});
  663.         my @tbl_2 = split(//, read_language()->{TBL_SMALL});
  664.         while (my $x = shift @tbl_2) {
  665.             if (my $y = shift @tbl_1) {
  666.                 $x = quotemeta($x);
  667.                 $string =~ s/$x/$y/;
  668.             }
  669.         }
  670.         return $string;
  671.     } else {
  672.         return uc($string);
  673.     }
  674. }
  675.  
  676. ###
  677. ### char_convert
  678. ###
  679. ### Converts selected characters to their HTML equivalents, controlled by
  680. ### charconvert.conf file, found in administration directory.  Can go
  681. ### either way depending on how it's called.
  682. ###
  683.  
  684. sub char_convert {
  685.     my ($stringin, $context, $args) = @_;
  686.     undef my @CHARCONVERT;
  687.     if (!defined($PARAMS->{'CHARCONVERT'})) {
  688.         if (open(CHAR, "$DCONF->{'admin_dir'}/charconvert.conf")) {
  689.             my @char = <CHAR>;
  690.             close (CHAR);
  691.             @char = grep(!/^\s*#/, @char);
  692.             @char = grep(/\S/, @char);
  693.             foreach my $line (@char) {
  694.                 if ($line =~ m|^\s*(\S+)\s*(.+)|) {
  695.                     my ($tag, $conv) = ($1, $2);
  696.                     $conv =~ s/\s+$//;
  697.                     if ($conv =~ m%\s*\<\|\s*$%) {
  698.                         $conv = $`;
  699.                         $conv =~ s/\$html_url/$DCONF->{'html_url'}/g;
  700.                         $conv =~ s/\$ext/$DCONF->{'ext'}/g;
  701.                         $conv =~ s/\$script_url/$DCONF->{'script_url'}/g;
  702.                         $conv =~ s/\$cgi_extension/$DCONF->{'cgi_extension'}/g;
  703.                         $conv =~ s/\$message_url/$DCONF->{'message_url'}/g;
  704.                         $conv =~ s/\$titlej/$DCONF->{'titlej'}/g;
  705.                         $conv =~ s/\$title/$DCONF->{'title'}/g;
  706.                         $conv =~ s/\$topic/$args->{'topic_number'}/g;
  707.                         $conv =~ s/\$page/$args->{'me_number'}/g;
  708.                     }
  709.                     push (@CHARCONVERT, "$tag\t$conv");
  710.                 }
  711.             }
  712.             $PARAMS->{'CHARCONVERT'} = \@CHARCONVERT;
  713.         } else {
  714.             $_ = $stringin;
  715.             if ($context == 0) {
  716.                 s/&/&/g; s/</\</g; s/>/\>/g; s/"/"/g; s/\\\\/\/g;
  717.                 s/\\\{/{/g; s/\\\}/}/g; s/\\,/,/g; s/\(/(/g;
  718.                 s/\)/)/g; s/\[/[/g; s/\]/]/g; s/\*/*/g; s/\+/+/g;
  719.                 s/\|/|/g; s/'/'/g;
  720.                 return $_;
  721.             } else {
  722.                 s/'/'/g; s/|/\|/g; s/+/\+/g; s/*/\*/g;
  723.                 s/]/\]/g; s/[/\[/g; s/)/\)/g; s/(/\(/g;
  724.                 s/,/,/g; s/}/\}/g; s/{/\{/g; s/\/\\/g;
  725.                 s/"/"/g; s/>/>/g; s/</</g; s/&/&/g;
  726.                 if ($args->{'JSP'} == 1) {
  727.                     $_ =~ s/<IMG SRC="[^"]*" ALT="([^"]*)"[^>]*>/\[$1\]/gi;
  728.                     $_ =~ s/<([^>]*)>//g if $args->{'nostrip'} == 0;
  729.                     $_ =~ s/\n//g;
  730.                     $_ =~ s/&#(\d+);//g;
  731.                     $_ =~ s/'//g;
  732.                     $_ =~ s/"//g;
  733.                     $_ =~ s/"//g;
  734.                     $_ =~ s/&//g;
  735.                 }
  736.                 return $_;
  737.             }
  738.         }
  739.     }
  740.     if ($context == 0) {
  741.         foreach my $tag (@{ $PARAMS->{'CHARCONVERT'} }) {
  742.             $tag =~ m|(\S+)\t(.*)|; my $conv = $2; my $line = quotemeta($1);
  743.             next if $conv =~ /\s*\|\>\s*$/;
  744.             $conv =~ s/\s*\<\>\s*$//;
  745.             $stringin =~ s/$line/$conv/g;
  746.         }
  747.         $stringin =~ s/\r\n/\n/g;
  748.         $stringin =~ s/\r/\n/g;
  749.         $stringin =~ s/\n/ <BR>/g;
  750.     } else {
  751.         $stringin =~ s/ <BR>/\n/g;
  752.         foreach my $tag (reverse(@{ $PARAMS->{'CHARCONVERT'} })) {
  753.             if ($tag =~ m|(\S+)\t(.*)|) {
  754.                 my $line = $1; my $conv = $2;
  755.                 next if $conv =~ /\s*\<\>\s*$/;
  756.                 $conv =~ s/\s*\|\>\s*$//; $conv = quotemeta($conv);
  757.                 $stringin =~ s/$conv/$line/g;
  758.             }
  759.         }
  760.         $stringin =~ s/\r\n/\n/g;
  761.         $stringin =~ s/\r/\n/g;
  762.         $stringin =~ s/ / /g;
  763.     }
  764.     if ($args->{'JSP'} == 1) {
  765.         $stringin =~ s/<IMG SRC="[^"]*" ALT="([^"]*)"[^>]*>/\[$1\]/gi;
  766.         $stringin =~ s/<([^>]*)>//g if $args->{'nostrip'} == 0;
  767.         if ($args->{'convert_html'} == 1) {
  768.             $stringin =~ s/([^\w&#; ])/makeord($1)/ge;
  769.             $stringin =~ s/\n//g;
  770.         } elsif ($args->{'convert_html'} == 2) {
  771.             $stringin =~ s/&#(\d+);/chr($1)/ge;
  772.             $stringin =~ s/"/"/g;
  773.             $stringin =~ s/&/&/g;
  774.         } elsif ($args->{'convert_html'} == 0) {
  775.             $stringin =~ s/&#(\d+);//g;
  776.             $stringin =~ s/'//g;
  777.             $stringin =~ s/"//g;
  778.             $stringin =~ s/"//g;
  779.             $stringin =~ s/&//g;
  780.             $stringin =~ s/\n//g;
  781.         }
  782.     }
  783.     return $stringin;
  784. }
  785.  
  786. ###
  787. ### error_message
  788. ###
  789. ### Exits gracefully should an error message be needed
  790. ###
  791.  
  792. sub error_message {
  793.     my ($reason, $explanation, $flag, $noerr, $nobug) = @_;
  794.     dreq("template");
  795.     my $subst = {};
  796.     $subst->{'general'}->{'reason'} = $reason;
  797.     $subst->{'general'}->{'explanation'} = $explanation;
  798.     $subst->{'general'}->{'flag'} = $flag;
  799.     $subst->{'general'}->{'noerr'} = $noerr;
  800.     $subst->{'general'}->{'nobug'} = $nobug;
  801.     $subst->{'general'}->{'excl_pt'} = $!;
  802.     $subst->{'general'}->{'perl'} = $];
  803.     $subst->{'general'}->{'cookies'} = $ENV{HTTP_COOKIE_STRING};
  804.     $subst->{'general'}->{'os'} = $^O;
  805.     return templ_int("errormsg", $subst) if $PARAMS->{no_exit};
  806.     screen_out("errormsg", $subst);
  807. }
  808.  
  809. ###
  810. ### seturl
  811. ###
  812. ### Redirects the browser to a new location.  If you have a REALLY old server
  813. ### (like Personal Web Server 1.0) where the "Location: " header doesn't work
  814. ### right, you may need to add "nph_server=1" to discus.conf.
  815. ###
  816.  
  817. sub seturl {
  818.     my ($targeturl, $noexit) = @_;
  819.     return "OK" if $PARAMS->{no_exit};
  820.     if (!($DCONF->{'nph_server'})) {
  821.         print "Location: $targeturl\n\n";
  822.         program_exit(0) if ! $noexit;
  823.     } else {
  824.         header();
  825.         print "<META HTTP-EQUIV=\"Refresh\" CONTENT=\"0; URL=$targeturl\">\n";
  826.         program_exit(0) if ! $noexit;
  827.     }
  828. }
  829.  
  830. ###
  831. ### lock
  832. ###
  833. ### Locks a file or files.
  834. ###
  835.  
  836. sub lock {
  837.     my $arg = ref $_[0] eq "HASH" ? shift @_ : undef;
  838.     my @files = @_;
  839.     my $subr_locker = $files[0] !~ m|[/\*\.]| ? shift @files : "";
  840.     my $max = (defined $arg->{max} ? $arg->{max} : 7);
  841.     if ($GLOBAL_OPTIONS->{performance_monitoring}) {
  842.         foreach my $file (@files) {
  843.             performance_string("-> [$subr_locker] Lock request on $file");
  844.             $PARAMS->{lockfiles}->{$file} = 1;
  845.         }
  846.     }
  847.     if ($GLOBAL_OPTIONS->{database}) {
  848.         dreq("dbint");
  849.         return sql_lock(\@files, $subr_locker, $max);
  850.     }
  851.     if ($GLOBAL_OPTIONS->{'lock_with_file'} == 1) {
  852.         dreq("lockfile");
  853.         while (my $f = unshift(@files)) {file_based_file_lock($f);}
  854.         return 1;
  855.     }
  856.     if ($GLOBAL_OPTIONS->{'lock_with_directory_file'}) {
  857.         dreq("locking");
  858.         return directory_file_based_file_lock(\@files, $subr_locker, $max);
  859.     }
  860.     foreach my $file (@files) {
  861.         my $filenm = $file =~ m|.*/(.*)| ? $1 : $file;
  862.         performance_string("# LOCK: requested on $file") if $GLOBAL_OPTIONS->{performance_monitoring};
  863.         $PARAMS->{files_locked}++;
  864.         if ($file eq "*") {
  865.             my $success = file_lock_do("GLOBAL");
  866.             if (! $success) {
  867.                 my $es = read_language()->{'FILELOCKREGEN'}; $es =~ s/\%sec/7/g;
  868.                 log_error("common.pl", "lock", "Request for lock on $filenm failed... [$$] (GLOBAL LOCK exists)");
  869.                 error_message(read_language()->{'FILELOCKERROR'}, "$es [$filenm]", 0, 1);
  870.             }
  871.             next;
  872.         } else {
  873.             my $Z = file_name_escape("GLOBAL");
  874.             my $lock_file = join("/", $DCONF->{admin_dir}, "locks", $Z);
  875.             if (-e $lock_file) {
  876.                 file_check_lock("GLOBAL");
  877.                 if (-e $lock_file) {
  878.                     my $es = read_language()->{'FILELOCKREGEN'}; $es =~ s/\%sec/7/g;
  879.                     log_error("common.pl", "file_lock", "Request for lock on $filenm failed... [$$] (GLOBAL LOCK exists)");
  880.                     error_message(read_language()->{'FILELOCKERROR'}, "$es [$filenm]", 0, 1);
  881.                 }
  882.             }
  883.             next if file_lock_do($filenm);
  884.             return 0 if $filenm eq "$DCONF->{board_topics_file}";
  885.             performance_string("# LOCK: *FAILED* lock on $file") if $GLOBAL_OPTIONS->{performance_monitoring};
  886.             log_error("common.pl", "file_lock", "Request for lock on $filenm failed");
  887.             error_message(read_language()->{'FILELOCKERROR'}, join("<br>", read_language()->{FILEISLOCKED}, "[$filenm]"), 0, 1);
  888.         }
  889.     }
  890.     return 1;
  891. }
  892.  
  893. ###
  894. ### unlock
  895. ###
  896. ### Unlocks a file or files.
  897. ###
  898.  
  899. sub unlock {
  900.     my @files = @_;
  901.     my $arg = undef;
  902.     $arg = shift @files if ref $files[0] eq "HASH";
  903.     shift @files if $files[0] !~ m|[\*/\.]|;
  904.     my $tcache = time;
  905.     if ($GLOBAL_OPTIONS->{performance_monitoring}) {
  906.         foreach my $file (@files) {
  907.             performance_string("-> Unlock request on $file");
  908.             delete $PARAMS->{lockfiles}->{$file};
  909.         }
  910.     }
  911.     if ($GLOBAL_OPTIONS->{database}) {
  912.         dreq("dbint");
  913.         return sql_unlock(\@files);
  914.     }
  915.     if ($GLOBAL_OPTIONS->{'lock_with_file'} == 1) {
  916.         dreq("lockfile");
  917.         file_based_file_unlock(@files);
  918.         return 1;
  919.     }
  920.     if ($GLOBAL_OPTIONS->{'lock_with_directory_file'}) {
  921.         dreq("locking");
  922.         return directory_file_based_file_unlock(\@files);
  923.     }
  924.     foreach my $file (@files) {
  925.         my $filenm = $file =~ m|.*/(.*)| ? $1 : $file;
  926.         performance_string("# UNLOCK: requested on $file") if $GLOBAL_OPTIONS->{performance_monitoring};
  927.         $PARAMS->{files_unlocked}++;
  928.         my $fn = $file eq "*" ? "GLOBAL" : $filenm;
  929.         my $Z = file_name_escape($fn);
  930.         if (-e "$DCONF->{admin_dir}/locks/$Z") {
  931.             if (! rmdir "$DCONF->{admin_dir}/locks/$Z") {
  932.                 my $d1 = $!;
  933.                 if (! unlink "$DCONF->{admin_dir}/locks/$Z") {
  934.                     log_error("common.pl", "unlock", "Unlocking of file '$file' failed: (rmdir: $d1; unlink: $!)");
  935.                     error_message("File Locking Malfunction", "File locking does not function properly on this server.", 0, 1);
  936.                 }
  937.             }
  938.         }
  939.     }
  940.     return 1;
  941. }
  942.  
  943. ###
  944. ### file_lock_do
  945. ###
  946. ### Actually does a file lock
  947. ###
  948.  
  949. sub file_lock_do {
  950.     my ($file) = @_;
  951.     my $Z = file_name_escape($file);
  952.     error_message("Illegal Lock Name", "[$Z]", 0, 1) if $Z !~ /^\w+$/;
  953.     my $lock_file = join("/", $DCONF->{admin_dir}, "locks", $Z);
  954.     my $tries = 0;
  955.     while ($tries <= 5) {
  956.         my $q = mkdir($lock_file, oct($DCONF->{perms0777}));
  957.         if ($q) {
  958.             chmod oct($DCONF->{perms0777}), $lock_file;
  959.             return 1;
  960.         }
  961.         if ($tries == 0) {
  962.             log_error("common.pl", "file_lock_do", "Could not create directory to lock '$file' due to: $!");
  963.         }
  964.         file_check_lock($file, $tries);
  965.         $tries++;
  966.     }
  967.     return 0;
  968. }
  969.  
  970. ###
  971. ### file_check_lock
  972. ###
  973. ### Checks to see if a file is locked, and removes stale locks
  974. ###
  975.  
  976. sub file_check_lock {
  977.     my ($file, $tries) = @_;
  978.     my $Z = file_name_escape($file);
  979.     my $lock_file = join("/", $DCONF->{admin_dir}, "locks", $Z);
  980.     my $timecache = time;
  981.     my $lock_mtime = file_get_mtime($lock_file);
  982.     if ($timecache - $lock_mtime >= 10 && -e $lock_file) {
  983.         log_error("common.pl", "file_check_lock", "Stale lock detected on $file: " . ($timecache-$lock_mtime) . " seconds old");
  984.         my $success = $file eq "GLOBAL" ? unlock("*") : unlock($file);
  985.         return 1 if $success;
  986.         file_lock_directory_cleanup($lock_file);
  987.         $success = unlock($file);
  988.         return 1 if $success;
  989.         error_message("File Locking Malfunction", "File locking does not function properly on this server.", 0, 1);
  990.     } elsif ($tries == 5 && -e $lock_file) {
  991.         log_error("common.pl", "file_check_lock", "Lock is valid: " . ($timecache-$lock_mtime) . " seconds old");
  992.     } elsif (! -e $lock_file) {
  993.         return 1;
  994.     }
  995.     return 0;
  996. }
  997.  
  998. ###
  999. ### file_name_escape
  1000. ###
  1001. ### Converts a file name into a unique string
  1002. ###
  1003.  
  1004. sub file_name_escape {
  1005.     my ($filename) = @_;
  1006.     my $escname = "";
  1007.     while ($filename =~ /(.)/sg) {
  1008.         $escname .= sprintf("%02lx", ord($1));
  1009.     }
  1010.     return $escname;
  1011. }
  1012.  
  1013. ###
  1014. ### file_get_mtime
  1015. ###
  1016. ### Gets the modified time of a file/directory
  1017. ###
  1018.  
  1019. sub file_get_mtime {
  1020.     return (stat $_[0])[9];
  1021. }
  1022.  
  1023. ###
  1024. ### file_lock_directory_cleanup
  1025. ###
  1026. ### Recursively deletes everything under a particular directory
  1027. ###
  1028.  
  1029. sub file_lock_directory_cleanup {
  1030.     my ($directory, $tries) = @_;
  1031.     log_error("common.pl", "file_lock_directory_cleanup", "Cleanup called on directory $directory (level = $tries)");
  1032.     if (opendir(DIR, $directory)) {
  1033.         my @dir = map { "$directory/$_" } grep { ! /^\.+$/ } readdir(DIR);
  1034.         closedir(DIR);
  1035.         foreach my $filename (@dir) {
  1036.             if (-f $filename) {
  1037.                 unlink $filename || log_error("common.pl", "file_lock_directory_cleanup", "File delete error: could not delete $filename ($!)");
  1038.             } elsif (-d $filename) {
  1039.                 if ($tries > 2) {
  1040.                     error_message("Recursive Directory Delete Error", "Directory $directory appears to be illegally recursive or complex.", 0, 1);
  1041.                 }
  1042.                 file_lock_directory_cleanup($filename, 1+$tries);
  1043.             }
  1044.         }
  1045.     }
  1046. }
  1047.  
  1048. ###
  1049. ### log_error
  1050. ###
  1051. ### Prints helpful debugging information in the errors.txt file should things go
  1052. ### wrong.
  1053. ###
  1054.  
  1055. sub log_error {
  1056.     my ($place, $sub, $message) = @_;
  1057.     my ($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst);
  1058.     if ($GLOBAL_OPTIONS->{'usegmtime'} == 1) {
  1059.         ($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst) = gmtime(time);
  1060.     } else {
  1061.         ($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst) = localtime(time);
  1062.     }
  1063.     open(ERROR_LOG, "$DCONF->{admin_dir}/errors.txt");
  1064.     my @error = <ERROR_LOG>;
  1065.     close (ERROR_LOG);
  1066.     foreach my $line (@error) {
  1067.         $line = "" if $line !~ m|\[\*\]|;
  1068.     }
  1069.     @error = grep(/\S/, @error);
  1070.     if (scalar(@error) > 300) {
  1071.         my $num = scalar(@error);
  1072.         @error = splice(@error, $num-300, 300);
  1073.     }
  1074.     $hour = "0$hour" if $hour < 10;
  1075.     $min = "0$min" if $min < 10;
  1076.     $sec = "0$sec" if $sec < 10;
  1077.     $nmonth += 1; $year += 1900;
  1078.     open (ERROR_LOG, ">$DCONF->{admin_dir}/errors.txt");
  1079.     print ERROR_LOG @error;
  1080.     print ERROR_LOG "-" x 60, "\n";
  1081.     print ERROR_LOG "[*] $nmonth/$day/$year $hour:$min:$sec $place/$sub $message\n";
  1082.     close (ERROR_LOG);
  1083. }
  1084.  
  1085.  
  1086. ###
  1087. ### determine_addmessage
  1088. ###
  1089. ### Determines if an "Add a Message" box should reflect private or public posting,
  1090. ### and whether anonymous posting is enabled.  Also returns per-topic selections
  1091. ### like disabling full name or e-mail addresses on posts.
  1092. ###
  1093.  
  1094. sub determine_addmessage {
  1095.     my ($topic, $privilege_in, $letter, $array_back) = @_;
  1096.     dreq("fcn-usrp");
  1097.     my $priv = (defined $privilege_in ? $privilege_in : read_topic_privilege_file(1));
  1098.     $letter = (defined $letter ? $letter : "p");
  1099.     undef my $result;
  1100.     my $x = $priv->{$topic}->{$letter};
  1101.     $result->{disabled} = 1 if ($x->{ip}->{':list:'} eq "" && $x->{user}->{':list:'} eq "" && $x->{moderator}->{':list:'} eq "" && $x->{special} eq "");
  1102.     $result->{public} = 1 if $x->{ip}->{':list:'} ne "";
  1103.     if ($DCONF->{pro} && ! $result->{public}) {
  1104.         dreq("ipaddr-PRO");
  1105.         $result->{public} = is_it_public($x->{ip}->{':list:'});
  1106.     }
  1107.     $result->{anonymous_posting} = 1;
  1108.     $result->{anonymous_posting} = 0 if $priv->{$topic}->{'o'}->{'anon'};
  1109.     $result->{anonymous_posting} = 0 if ! $GLOBAL_OPTIONS->{'anonymous'};
  1110.     return ($result, $priv) if $array_back;
  1111.     return $result;
  1112. }
  1113.  
  1114. ###
  1115. ### extract_info
  1116. ###
  1117. ### Called if tree file is corrupt to determine necessary parameters for
  1118. ### generating a subtopic list.
  1119. ###
  1120.  
  1121. sub extract_info {
  1122.     my ($topic, $page, $arg) = @_;
  1123.     my $hashref = {};
  1124.     my $get_page = GetPage($topic, $page, $arg);
  1125.     $hashref->{topic} = $get_page->{head}->{topic_number};
  1126.     $hashref->{page} = $get_page->{head}->{me_number};
  1127.     $hashref->{number} = $get_page->{head}->{me_number};
  1128.     $hashref->{name} = $get_page->{head}->{me_name};
  1129.     $hashref->{parent} = $get_page->{head}->{parent};
  1130.     $hashref->{properties} = $get_page->{head}->{properties};
  1131.     $hashref->{param} = $get_page->{head}->{param};
  1132.     return $hashref;
  1133. }
  1134.  
  1135. ###
  1136. ### GetPage
  1137. ###
  1138. ### Reads in all information from a message page and puts it into a format
  1139. ### that's easily manipulated.  This can handle board-generated pages from
  1140. ### version 3.10 and 4.00+
  1141. ###
  1142.  
  1143. sub GetPage {
  1144.     my ($topic, $page, $arg, $fileref) = @_;
  1145.     undef my $hashref;
  1146.     undef my $head;
  1147.     $head->{pageversion} = "4.0";
  1148.     my $q = get_message_path($topic);
  1149.     my $filename = join("/", $q, "$page.$DCONF->{ext}");
  1150.     my $arguments = {};
  1151.     $arguments->{no_lock} = $arg->{lock} == 1 ? 0 : 1;
  1152.     $arguments->{no_unlock} = $arg->{unlock} == 1 ? 0 : 1;
  1153.     $arguments->{zero_ok} = $arg->{zero_ok} == 1 ? 1 : 0;
  1154.     if (! defined $fileref) {
  1155.         error_message("Invalid GetPage Argument", "Topic [$topic] contains invalid characters!", 0, 1) if $topic =~ m|\D|;
  1156.         error_message("Invalid GetPage Argument", "Page [$page] contains invalid characters!", 0, 1) if $page =~ m|\D|;
  1157.         performance_string("& GetPage for $topic/$page ", keyspew($arg)) if $GLOBAL_OPTIONS->{performance_monitoring};
  1158.         if (! -f $filename) {
  1159.             error_message(read_language()->{GET_PAGE_OPEN_ERROR}, read_language()->{GET_PAGE_OPEN_ERROR_DESCR} . "</p><p>$topic/$page", 0, 1) if !$arg->{no_error};
  1160.             return {};
  1161.         }
  1162.         $fileref = readfile($filename, "GetPage", $arguments);
  1163.         chmod(oct($DCONF->{perms0666}), $filename);
  1164.     }
  1165.     $hashref->{secure} = $q eq $DCONF->{secdir} ? 1 : 0;
  1166.     my @level = ();
  1167.     my @sublist = ();
  1168.     my @messages = ();
  1169.     my @empty = ();
  1170.     undef my $subref;
  1171.     undef my $postref;
  1172.     undef my @sublist_raw;
  1173.     undef my @messages_raw;
  1174.     undef my @header_string;
  1175.     my $flag = 0;
  1176.     my $filelen = 0;
  1177.     my $stflag = 0;
  1178.     my $srflag = 0;
  1179.     my $mrflag = 0;
  1180.     my $stsarr = {};
  1181.     my $post = "";
  1182.     my $storeflag = "";
  1183.     my $seenpost = {};
  1184.     foreach $_ (@{ $fileref }) {
  1185.         $filelen += length($_);
  1186.         if ($flag || $stflag || $storeflag || $srflag || $mrflag || m|<!--?.*-[-!]>|) {
  1187.             if (m|^<!--Topic: (\d+)/(.*)-->\s*$|) {
  1188.                 ($head->{'topic_number'}, $head->{'topic_name'}) = ($1, $2);
  1189.                 push (@header_string, $_);
  1190.             } elsif (m|<!--Me: (\d+)/(.*)-->\s*$|) {
  1191.                 $head->{me_number} = $1; $head->{me_name} = $2;
  1192.                 push (@header_string, $_);
  1193.             } elsif (m|<!--Level (\d+): (\d+)/(.*)-->\s*$|) {
  1194.                 $level[$1] = {level_number => $2, level_name => $3};
  1195.                 push (@header_string, $_);
  1196.             } elsif (m|^<!--Param: (\w+)-->\s*$|) {
  1197.                 $head->{'param'} = $1;
  1198.                 push (@header_string, $_);
  1199.             } elsif (m|^<!--Parent: (\d+)-->\s*$|) {
  1200.                 $head->{'parent'} = $1;
  1201.                 push (@header_string, $_);
  1202.             } elsif (m|^<!--Properties: (.*)-->|) {
  1203.                 $head->{'properties'} = $1;
  1204.                 push (@header_string, $_);
  1205.             } elsif (m|^<!--Owner:\s*(.*)-->|) {
  1206.                 $head->{'pageversion'} = "3.1";
  1207.                 $head->{'owner'} = $1;
  1208.             } elsif (m|^\s*<!--Store: (\w+)-->\s*$|i) {
  1209.                 $storeflag = $1;
  1210.             } elsif ($storeflag ne "") {
  1211.                 if (m|^\s*<!--/Store-->\s*$|i) {
  1212.                     $storeflag = "";
  1213.                 } else {
  1214.                     $hashref->{store}->{$storeflag} .= $_;
  1215.                 }
  1216.             } elsif (m|^\s*<!--?Top: (\d+)-[!\-]>|i) {
  1217.                 if ($stsarr->{$1}) {
  1218.                     $stflag = 0;
  1219.                     $subref = {};
  1220.                     next;
  1221.                 }
  1222.                 my $aft = $';
  1223.                 $subref = {};
  1224.                 $subref->{'number'} = $1;
  1225.                 $subref->{'type'} = 0;
  1226.                 if ($aft =~ /^\s*$/) {
  1227.                     $stflag = 1;
  1228.                 } else {
  1229.                     push @sublist, $subref;
  1230.                     $stsarr->{$subref->{number}} = 1;
  1231.                 }
  1232.                 push @sublist_raw, $_;
  1233.                 $subref->{'descr'} = $1 if m|<!--Descr-->(.*?)<!--/Descr-->|i;
  1234.             } elsif (m|<!--/Top-->| || $stflag == 1) {
  1235.                 next if $subref->{number} == 0;
  1236.                 push @sublist_raw, $_;
  1237.                 $stflag = 0 if m|<!--/Top-->|;
  1238.                 $subref->{'descr'} = $1 if m|<!--Descr-->(.*?)<!--/Descr-->|i;
  1239.                 if (m|<!--/Top-->|) {
  1240.                     push @sublist, $subref;
  1241.                     $stsarr->{$subref->{number}} = 1;
  1242.                 }
  1243.             } elsif (m|^\s*<!--?URL: (\d+)-[\!\-]>|) {
  1244.                 push @sublist_raw, $_;
  1245.                 my $aft = $';
  1246.                 $subref = {};
  1247.                 $subref->{'islink'} = 1;
  1248.                 $subref->{'number'} = $1;
  1249.                 $subref->{'type'} = 1;
  1250.                 $subref->{'descr'} = $1 if m|<!--Descr-->(.*?)<!--/Descr-->|i;
  1251.                 if (m|<!--Name-->(.*?)<!--/Name-->|) {
  1252.                     $subref->{name} = $1;
  1253.                 } elsif (m|<a.*?>(.*?)</a>|i) {
  1254.                     $subref->{name} = $1;
  1255.                 }
  1256.                 if ($aft =~ m|<!--Data: ([^\-]*)-([^\-]*)-([^\-]*) -->|i) {
  1257.                     $aft = $'; my $b4 = $`;
  1258.                     $subref->{url} = unescape($1);
  1259.                     $subref->{target} = unescape($2);
  1260.                     $subref->{props} = unescape($3);
  1261.                     $subref = hash_merge($subref, generate_properties_hash($subref->{props}), 1);
  1262.                     if ($aft =~ /^\s*$/ && $b4 =~ /^\s*$/) {
  1263.                         $stflag = 2;
  1264.                     } else {
  1265.                         push @sublist, $subref;
  1266.                     }
  1267.                 } elsif ($aft =~ /^\s*$/) {
  1268.                     $stflag = 2;
  1269.                 } else {
  1270.                     $subref->{url} = $1 if m|<a href="([^"]+)"|i;
  1271.                     $subref->{target} = $1 if m| target="([^"]+)"|i;
  1272.                     push @sublist, $subref;
  1273.                 }
  1274.             } elsif (m|<!--/URL-->| || $stflag == 2) {
  1275.                 push @sublist_raw, $_;
  1276.                 $stflag = 0 if m|<!--/URL-->|;
  1277.                 $subref->{'descr'} = $1 if m|<!--Descr-->(.*?)<!--/Descr-->|i;
  1278.                 if (m|<!--Name-->(.*?)<!--/Name-->|) {
  1279.                     $subref->{name} = $1;
  1280.                 } elsif ($subref->{name} eq "" && m|<a.*?>(.*?)</a>|i) {
  1281.                     $subref->{name} = $1;
  1282.                 }
  1283.                 if (m|<!--Data: ([^\-]*)-([^\-]*)-([^\-]*) -->|i) {
  1284.                     $subref->{url} = unescape($1);
  1285.                     $subref->{target} = unescape($2);
  1286.                     $subref->{props} = unescape($3);
  1287.                     $subref = hash_merge($subref, generate_properties_hash($subref->{props}), 1);
  1288.                 } elsif ($subref->{url} eq "") {
  1289.                     $subref->{url} = $1 if m|<a href="([^"]+)"|i;
  1290.                     $subref->{target} = $1 if m| target="([^"]+)"|i;
  1291.                 }
  1292.                 push @sublist, $subref if m|<!--/URL-->|;
  1293.             } elsif (m|^\s*<!--?Post: (\d+)-[!\-]><!--?Time: (\d+)-[!\-]>|i) {
  1294.                 my ($pn, $tn) = ($1, $2); my $pntn = join(":", $pn, $tn);
  1295.                 if ($seenpost->{$pntn}) {
  1296.                     log_error("common.pl", "GetPage", "Duplicate post number $pn on page $topic/$page");
  1297.                     next;
  1298.                 }
  1299.                 $seenpost->{$pntn} = 1;
  1300.                 $flag = 1; $stflag = 0;
  1301.                 undef $postref;
  1302.                 $postref->{'number'} = $1;
  1303.                 $postref->{'time'} = $tn > 0 ? $tn : time;
  1304.                 $postref->{'fields'} = [];
  1305.                 push (@messages_raw, $_);
  1306.             } elsif (m|^\s*<!--?Post: (\d+)-[!\-]>|i) {
  1307.                 if ($seenpost->{"$1:0"}) {
  1308.                     log_error("common.pl", "GetPage", "Duplicate post number $1 on page $topic/$page");
  1309.                     next;
  1310.                 }
  1311.                 $seenpost->{"$1:0"} = 1;
  1312.                 $flag = 1; $stflag = 0;
  1313.                 $postref = {};
  1314.                 $postref->{'number'} = $1;
  1315.                 $postref->{'time'} = time;
  1316.                 $postref->{'fields'} = [];
  1317.                 push (@messages_raw, $_);
  1318.                 $post = $_;
  1319.             } elsif ($flag == 1 && m|<!--?/Post: (\d+)-[!\-]>|i) {
  1320.                 $flag = 0; $stflag = 0;
  1321.                 push (@messages_raw, $_);
  1322.                 $_ = join("", $post, $_); $post = "";
  1323.                 $postref->{'text'} = $1 if m|<!--?Text-[!\-]>(.*?)<!--?/Text-[!\-]>|is;
  1324.                 $postref->{'author'} = $1 if m|<!--?Name-[!\-]>(.*?)<!--?/Name-[!\-]>|i;
  1325.                 $postref->{'email'} = $1 if m|<!--?Email-[!\-]>(.*?)<!--?/Email-[!\-]>|i;
  1326.                 $postref->{'email'} = $1 if $postref->{'email'} =~ m|href="(.*?)"|i;
  1327.                 if ($postref->{email} =~ m|profile=(.*?)-(\w+)|) {
  1328.                     $postref->{'email'} = "$DCONF->{script_url}/board-profile.$DCONF->{cgi_extension}?action=view_profile&profile=$1-";
  1329.                     $postref->{'email'} .= $2 eq "MODERATOR" ? $2 : "users";
  1330.                 }
  1331.                 $postref->{'email'} = "" if $postref->{'email'} =~ m|javascript:alert|;
  1332.                 if (m|<!--f|) {
  1333.                     my $used_field = {};
  1334.                     my $temp = $_;
  1335. W2:                    while ($temp =~ m|<!--f(ield)?/(.*?):(.*?)-->|i) {
  1336.                         my ($one, $two) = ($2, $3); $temp = join("", $`, $');
  1337.                         next W2 if $used_field->{$one};
  1338.                         $used_field->{$one} = 1;
  1339.                         $postref->{"field_$one"} = unescape($two);
  1340.                         push @{ $postref->{fields} }, { name => $one, value => unescape($two) };
  1341.                     }
  1342. W1:                    while ($temp =~ m|<!--f(ield)?:(.*?)-->(.*?)<!--/f(ield)?-?-?>|i) {
  1343.                         my ($one, $two) = ($2, $3); $temp = $';
  1344.                         next W1 if $used_field->{$one};
  1345.                         $used_field->{$one} = 1;
  1346.                         $two = $2 if $two =~ m|<!--u(se)?:\s?(.*?)-->|i;
  1347.                         $postref->{"field_$one"} = $two;
  1348.                         push @{ $postref->{fields} }, { name => $one, value => $two };
  1349.                     }
  1350.                 }
  1351.                 if (/<!--p(rop|roperty|roperties)?:(.*?)-->/) {
  1352.                     my (@pairs) = split(/&/, $2);
  1353.                     foreach my $pair (@pairs) {
  1354.                         my ($name, $value) = split(/=/, $pair);
  1355.                         $postref->{"property_$name"} = unescape($value);
  1356.                     }
  1357.                 }
  1358.                 # Hack for free version so skins work right
  1359.                 if (! $DCONF->{pro} && $postref->{field_registered} ne "") {
  1360.                     $postref->{author_status} = 3 if $postref->{author_status} <= 2;
  1361.                 }
  1362.                 push (@messages, $postref);
  1363.             } elsif ($flag == 1) {
  1364.                 push (@messages_raw, $_);
  1365.                 $post .= $_;
  1366.             } elsif (m|^<!--Begin Subtopic List-->\s*$|) {
  1367.                 $srflag = 1;
  1368.             } elsif (m|^<!--End Subtopic List-->\s*$|) {
  1369.                 $srflag = 0;
  1370.             } elsif (m|^<!--Begin Message List-->\s*$|) {
  1371.                 $mrflag = 1;
  1372.             } elsif (m|^<!--End Message List-->\s*$|) {
  1373.                 $mrflag = 0;
  1374.             } elsif (m|^<!--Announcement-->|) {
  1375.                 $flag = 2;
  1376.             } elsif (m|^<!--/Announcement-->|) {
  1377.                 $flag = 0;
  1378.             } elsif (m|^<!--Announcement Source:|) {
  1379.                 $flag = 0;
  1380.             } elsif (m|^<!--Source:|) {
  1381.                 $flag = 0;
  1382.             } elsif (m|^<!--About-->|) {
  1383.                 $flag = 3;
  1384.             } elsif (m|^<!--/About-->|) {
  1385.                 $flag = 0;
  1386.             } elsif ($flag == 2 || $flag == 3) {
  1387.                 next if m|^<!--?Skip-[!\-]>|;
  1388.                 next if m|^-->|;
  1389.                 next if m|^\s*<HR>\s*$|i;
  1390.                 next if m|^<!--|;
  1391.                 $hashref->{'pginfo'}->{'announcement'} .= $_ if $flag == 2 && m|\S|;
  1392.                 $hashref->{'pginfo'}->{'about'} .= $_ if $flag == 3 && m|\S|;
  1393.             } elsif ($mrflag) {
  1394.                 push @messages_raw, $_;
  1395.             } elsif ($srflag) {
  1396.                 push @sublist_raw, $_;
  1397.             }
  1398.         } elsif (m%^<META\s*(?:NAME|HTTP-EQUIV)="([^"]+)"\s*(?:CONTENT|VALUE)="([^"]*)">\s*$%i) {
  1399.             $stflag = 0;
  1400.             my $keyname = join("_", "meta", trim(lc($1)));
  1401.             $hashref->{$keyname} = $2;
  1402.         } elsif (m|^\s*</HTML>\s*$|i) {
  1403.             $hashref->{'pginfo'}->{'complete'} = 1;
  1404.         }
  1405.     }
  1406.     $head->{'levels'} = \@level;
  1407.     $hashref->{'head'} = $head;
  1408.     $hashref->{'head'}->{'topic_number'} = $topic;
  1409.     $hashref->{'head'}->{'me_number'} = $page if $page;
  1410.     $hashref->{'sublist'} = \@sublist;
  1411.     $hashref->{'messages'} = \@messages;
  1412.     $hashref->{'sublist_raw'} = join("", @sublist_raw);
  1413.     $hashref->{'messages_raw'} = join("", @messages_raw);
  1414.     $hashref->{pginfo}->{'headers_asstring'} = join("", @header_string);
  1415.     $hashref->{'general'}->{'subtopic_raw'} = 1;
  1416.     $hashref->{'general'}->{'messages_raw'} = 1;
  1417.     $hashref->{'general'}->{'levels'} = scalar(@level);
  1418.     $hashref->{'general'}->{'length'} = $filelen;
  1419.     return $hashref;
  1420. }
  1421.  
  1422. ###
  1423. ### SetPage
  1424. ###
  1425. ### Writes out a message file.
  1426. ###
  1427.  
  1428. sub SetPage {
  1429.     my ($hashref, $args) = @_;
  1430.     my $subst = $hashref;
  1431.     my $topic = $hashref->{'head'}->{'topic_number'};
  1432.     my $page = $hashref->{'head'}->{'me_number'};
  1433.     performance_string("& SetPage for $topic/$page ", keyspew($args)) if $GLOBAL_OPTIONS->{performance_monitoring};
  1434.     undef my $arguments;
  1435.     $arguments->{no_lock} = ($args->{lock} == 1 ? 0 : 1);
  1436.     $arguments->{no_unlock} = ($args->{unlock} == 1 ? 0 : 1);
  1437.     my $params = $hashref;
  1438.     undef my @header_string;
  1439.     push (@header_string, "<!--Topic: $params->{head}->{topic_number}/$params->{head}->{topic_name}-->");
  1440.     push (@header_string, "<!--Me: $params->{head}->{me_number}/$params->{head}->{me_name}-->");
  1441.     my $ctr = 1; my $seen = 0;
  1442.     foreach my $x (@{ $params->{head}->{levels} }) {
  1443.         next if $x->{level_number} == 0;
  1444.         push (@header_string, "<!--Level $ctr: $x->{level_number}/$x->{level_name}-->");
  1445.         $ctr++;
  1446.         $seen = 1 if $x->{level_number} == $params->{head}->{me_number};
  1447.     }
  1448.     if ($seen == 0 && $params->{head}->{topic_number} != $params->{head}->{me_number}) {
  1449.         push (@header_string, "<!--Level $ctr: $params->{head}->{me_number}/$params->{head}->{me_name}-->");
  1450.     }
  1451.     push (@header_string, "<!--Properties: $params->{head}->{properties}-->");
  1452.     push (@header_string, "<!--Param: $params->{head}->{param}-->");
  1453.     push (@header_string, "<!--Parent: $params->{head}->{parent}-->");
  1454.     push (@header_string, "<!--Owner: $params->{head}->{owner}-->") if $params->{head}->{owner};
  1455.     $subst->{pginfo}->{headers_asstring} = join("\n", @header_string, "");
  1456.     dreq("template");
  1457.     my $template = "";
  1458.     $subst->{'general'}->{'warning'} = "<!-- WARNING: Do not edit this file with an HTML editor! -->\n";
  1459.     $subst->{'subtopics'} = $hashref->{'sublist'};
  1460.     $subst->{'pginfo'}->{'sublist_raw'} = $hashref->{'sublist_raw'};
  1461.     $subst->{'pginfo'}->{'messages_raw'} = $hashref->{'messages_raw'};
  1462.     $subst->{'pginfo'}->{'meta_description'} = $hashref->{'meta_description'};
  1463.     $subst->{'pginfo'}->{'meta_keywords'} = $hashref->{'meta_keywords'};
  1464.     $subst->{'pginfo'}->{'meta_robots'} = $hashref->{'meta_robots'};
  1465.     $subst->{'pginfo'}->{'subtopics_regular'} = 0;
  1466.     $subst->{'pginfo'}->{'subtopics_archives'} = 0;
  1467.     if (ref $subst->{'subtopics'} eq 'ARRAY') {
  1468.         foreach my $subtopic (@{ $subst->{'subtopics'} }) {
  1469.             if ($subtopic->{param} =~ /Archive/) {
  1470.                 $subst->{'pginfo'}->{'subtopics_archives'}++;
  1471.             } else {
  1472.                 $subst->{'pginfo'}->{'subtopics_regular'}++;
  1473.             }
  1474.         }
  1475.     }
  1476.     $subst->{'levels'} = $hashref->{'head'}->{'levels'};
  1477.     my @msg = ();
  1478.     if (ref $hashref->{messages} eq "ARRAY") {
  1479.         foreach my $message (@{ $hashref->{messages} }) {
  1480.             my @k = grep(/^property_/, keys(%{ $message })); my @u = ();
  1481.             foreach my $k (@k) {
  1482.                 $k =~ /^property_/; my $l = $';
  1483.                 push @u, join("=", $l, escape($message->{$k}));
  1484.             }
  1485.             $message->{property} = join("&", @u);
  1486.             push @msg, $message;
  1487.         }
  1488.     }
  1489.     $subst->{'messages'} = \@msg;
  1490.     my $file = join("/", get_message_path($topic), "$page.$DCONF->{ext}");
  1491.     $subst->{general}->{showadminfromhere} = 1;
  1492.     if ($params->{head}->{param} =~ m|Add|) {
  1493.         $subst->{addmessage} = determine_addmessage($hashref->{head}->{topic_number}, $args->{privcache});
  1494.     }
  1495.     if ($args->{return_val}) {
  1496.         return templ_int("*$params->{head}->{topic_number}page", $subst);
  1497.     } else {
  1498.         my $text = templ_int("*$params->{head}->{topic_number}page", $subst);
  1499.         my @text = ( $text );
  1500.         writefile($file, \@text, "SetPage", $arguments );
  1501.         return $hashref;
  1502.     }
  1503. }
  1504.  
  1505. ###
  1506. ### expand_sublist
  1507. ###
  1508. ### Combines tree information with the subtopic list to be sure each subtopic
  1509. ### in a list has the proper information.  Also determines the icon to display
  1510. ### next to each subtopic.
  1511. ###
  1512.  
  1513. sub expand_sublist {
  1514.     my ($subref, $topic, $special_in) = @_;
  1515.     if (defined $special_in || ! defined($PARAMS->{"lookup:$topic"})) {
  1516.         my $rdtree = defined $special_in ? $special_in : read_tree($topic, undef);
  1517.         $PARAMS->{"lookup:$topic"} = {};
  1518.         foreach my $x (@{ $rdtree }) {
  1519.             $PARAMS->{"lookup:$topic"}->{ $x->{page} } = $x;
  1520.         }
  1521.     }
  1522.     foreach my $t (@{ $subref }) {
  1523.         my $y = $PARAMS->{"lookup:$topic"}->{ $t->{number} };
  1524.         foreach my $v (split(/;/, $y->{properties})) {
  1525.             my ($var, $val) = split(/=/, $v);
  1526.             $y->{"property_$var"} = $val;
  1527.         }
  1528.         if (ref $y->{props} eq "HASH") {
  1529.             foreach my $k (keys(%{ $y->{props} })) {
  1530.                 $y->{"property_$k"} = $y->{props}->{$k};
  1531.             }
  1532.             $y->{properties} = generate_properties(hash_merge(generate_properties_hash($y->{properties}),$y->{props},1));
  1533.         }
  1534.         $t->{msg_count} = $y->{posts};
  1535.         $t->{param} = $y->{param};
  1536.         $t->{name} = $y->{name};
  1537.         $t->{subs} = $y->{subs};
  1538.         $t->{last_poster} = $y->{last_poster};
  1539.         $t->{originator} = $y->{originator};
  1540.         $t->{lastmod} = $y->{lastmod};
  1541.         $t->{url} = $y->{url};
  1542.         $t->{islink} = $y->{islink};
  1543.         $t->{icon} = tree_icon_chooser($y->{icon}, $y->{param}, $y->{islink});
  1544.         $t->{properties} = $y->{properties};
  1545.         $t->{property_emot} = $y->{property_emot};
  1546.     }
  1547.     return $subref;
  1548. }
  1549.  
  1550. ###
  1551. ### tree_icon_chooser
  1552. ###
  1553. ### Chooses default icons depending on parameters of the page
  1554. ###
  1555.  
  1556. sub tree_icon_chooser {
  1557.     my ($icon, $param, $islink, $letteronly) = @_;
  1558.     my $r = "";
  1559.     $r = $icon if $icon ne "" && $icon ne "0";
  1560.     $r = "tree_t" if ($r eq "" && $param =~ m|Archive| && $param =~ m|Sublist|);
  1561.     $r = "tree_u" if ($r eq "" && $param =~ m|Archive|);
  1562.     $r = "tree_r" if ($r eq "" && $param =~ m|Add|);
  1563.     $r = "tree_o" if ($r eq "" && $param =~ m|Messages|);
  1564.     $r = "tree_m" if ($r eq "" && $islink);
  1565.     $r = "tree_n" if $r eq "";
  1566.     $r =~ s/^tree_// if $letteronly;
  1567.     return $r;
  1568. }
  1569.  
  1570. ###
  1571. ### sort_archive_method
  1572. ###
  1573. ### Pushes archives to the bottom of a subtopic list
  1574. ###
  1575.  
  1576. sub sort_archive_method {
  1577.     my ($ap, $bp) = ($a->{param}, $b->{param});
  1578.     return 1 if $a->{lastmod} == 1 && $b->{lastmod} != 1;
  1579.     return -1 if $a->{lastmod} != 1 && $b->{lastmod} == 1;
  1580.     return 0 if $a->{lastmod} == 1 && $b->{lastmod} == 1;
  1581.     return 1  if $ap =~ /Archive/ && $bp !~ /Archive/;
  1582.     return -1 if $ap !~ /Archive/ && $bp =~ /Archive/;
  1583.     return 0 if $ap !~ /Archive/ && $bp !~ /Archive/;
  1584.     return $a->{lastmod} <=> $b->{lastmod} if $GLOBAL_OPTIONS->{sort_archive_method_choice} >= 0;
  1585.     return $b->{lastmod} <=> $a->{lastmod};
  1586. }
  1587.  
  1588. ###
  1589. ### topic_tree_to_main
  1590. ###
  1591. ### Writes the first line of a ###-tree.txt file to the main tree.txt file.
  1592. ###
  1593.  
  1594. sub topic_tree_to_main {
  1595.     my ($topicref, $tree_in, $arg) = @_;
  1596.     my $tree = defined $tree_in ? $tree_in : readfile("$DCONF->{admin_dir}/tree.txt", "topic_tree_to_main", { no_unlock => 1 });
  1597.     my $written = 0;
  1598.     foreach my $t_l (@{ $tree }) {
  1599.         my @c2 = split(/\t/, $t_l);
  1600.         if ($c2[1] == $topicref->[0]->{topic}) {
  1601.             $t_l = (generate_tree_line($topicref->[0]))[0];
  1602.             $written = 1;
  1603.             last;
  1604.         }
  1605.     }
  1606.     push (@{ $tree }, (generate_tree_line($topicref->[0]))[0]) if !$written;
  1607.     writefile("$DCONF->{admin_dir}/tree.txt", $tree, "topic_tree_to_main", { no_lock => 1 }) if ! $arg->{no_write};
  1608.     return $tree;
  1609. }
  1610.  
  1611. ###
  1612. ### tree_line_as_hash
  1613. ###
  1614. ### Takes a line from the tree.txt file and generates a hash that is easily manipulated
  1615. ### by the program.  Inverse is "generate_tree_line".
  1616. ###
  1617.  
  1618. sub tree_line_as_hash {
  1619.     my ($line) = @_;
  1620.     return undef if $line !~ m|^\d|;
  1621.     chomp $line;
  1622.     undef my $h;
  1623.     ($h->{'level'}, $h->{'topic'}, $h->{'page'}, $h->{'parent'}, $h->{'name_esc'}, $h->{'param'}, $h->{'url_esc'}, $h->{'posts'}, $h->{'properties'}, $h->{'lastmod'}, $h->{'originator_esc'}, $h->{'post_list'}, $h->{'subs'}, $h->{'last_poster_esc'}) = split(/\t/,$line);
  1624.     $h->{'parent'} = 0 if $h->{'topic'} == $h->{'page'};
  1625.     $h->{'name'} = unescape($h->{'name_esc'});
  1626.     undef $h->{name_esc};
  1627.     $h->{'originator'} = unescape($h->{'originator_esc'});
  1628.     undef $h->{originator_esc};
  1629.     $h->{'last_poster'} = unescape($h->{'last_poster_esc'});
  1630.     undef $h->{last_poster_esc};
  1631.     if ($h->{'param'} =~ m|^LINK:|) {
  1632.         $h->{'islink'} = 1;
  1633.         $h->{'target'} = $';
  1634.         $h->{'url'} = unescape($h->{'url_esc'});
  1635.     } else {
  1636.         undef $h->{'islink'};
  1637.         undef $h->{'target'};
  1638.         undef $h->{'url'};
  1639.     }
  1640.     undef $h->{url_esc};
  1641.     $h->{'posts'} = 0 if $h->{'posts'} == 0;
  1642.     $h->{'subs'} = 0 if $h->{'subs'} == 0;
  1643.     foreach my $p (split(/;/, $h->{properties})) {
  1644.         $h->{"property_$1"} = $2 if $p =~ m|^(\w+)=(\w+)|;
  1645.     }
  1646.     $h->{icon} = $h->{property_icon} if defined $h->{property_icon};
  1647. #    $h->{icon} = tree_icon_chooser($h->{property_icon}, $h->{param}, $h->{islink});
  1648.     return $h;
  1649. }
  1650.  
  1651. ###
  1652. ### generate_tree_line
  1653. ###
  1654. ### Generates a line for the tree.txt file based on incoming input, ensuring that
  1655. ### no entry is left blank by substituting in default values.  Inverse is
  1656. ### "tree_line_as_hash".
  1657. ###
  1658.  
  1659. sub generate_tree_line {
  1660.     my ($params) = @_;
  1661.     undef my $result;
  1662.     $result->{'level'} = ( defined($params->{'level'}) ? $params->{'level'} : 0 );
  1663.     $result->{'topic'} = ( defined($params->{'topic'}) ? $params->{'topic'} : 0 );
  1664.     $result->{'page'} = ( defined($params->{'page'}) ? $params->{'page'} : 0 );
  1665.     $result->{'parent'} = ( defined($params->{'parent'}) ? $params->{'parent'} : 0 );
  1666.     $result->{'name_esc'} = ( defined($params->{'name_esc'}) ? $params->{'name_esc'} : escape($params->{name}) );
  1667.     $result->{'param'} = ( defined($params->{'islink'}) ? "LINK:$params->{target}" : $params->{'param'} );
  1668.     $result->{'url_esc'} = ( defined($params->{'url_esc'}) ? $params->{'url_esc'} : escape($params->{url}) );
  1669.     $result->{'posts'} = ( defined($params->{'posts'}) ? $params->{'posts'} : 0 );
  1670.     $result->{'properties'} = ( defined($params->{'properties'}) ? $params->{'properties'} : generate_properties($params->{props}) );
  1671.     $result->{'lastmod'} = ( defined($params->{'lastmod'}) ? $params->{'lastmod'} : time );
  1672.     $result->{'originator_esc'} = ( defined($params->{'originator_esc'}) ? $params->{'originator_esc'} : escape($params->{originator}));
  1673.     $result->{'post_list'} = ( defined($params->{'post_list'}) ? $params->{'post_list'} : "" );
  1674.     $result->{'subs'} = ( defined($params->{'subs'}) ? $params->{'subs'} : 0 );
  1675.     $result->{'last_poster_esc'} = ( defined($params->{'last_poster_esc'}) ? $params->{'last_poster_esc'} : escape($params->{last_poster}) );
  1676.     my $r = $result;
  1677.     my $line = join("\t", $r->{level}, $r->{topic}, $r->{page}, $r->{parent}, $r->{name_esc}, $r->{param}, $r->{url_esc}, $r->{posts}, $r->{properties}, $r->{lastmod}, $r->{originator_esc}, $r->{post_list}, $r->{subs}, $r->{last_poster_esc});
  1678.     $line =~ s/[\r\n]//g;
  1679.     $line .= "\n";
  1680.     return ($line, $result);
  1681. }
  1682.  
  1683. ###
  1684. ### generate_properties
  1685. ###
  1686. ### Generates a "properties" string suitable to write into a file or include into
  1687. ### the tree file, from a hash reference of properties.
  1688. ###
  1689.  
  1690. sub generate_properties {
  1691.     my ($hash_in) = @_;
  1692.     undef my @arr_out;
  1693.     foreach my $key (keys(%{$hash_in})) {
  1694.         push (@arr_out, "$key=$hash_in->{$key}");
  1695.     }
  1696.     return join(";", @arr_out);
  1697. }
  1698.  
  1699. ###
  1700. ### generate_properties_hash
  1701. ###
  1702. ### Inverse of generate_properties
  1703. ###
  1704.  
  1705. sub generate_properties_hash {
  1706.     my ($string_in) = @_;
  1707.     my @arr = split(/;/, $string_in);
  1708.     my $hash = {};
  1709.     foreach my $z (@arr) {
  1710.         my ($key, $val) = split(/=/, $z, 2);
  1711.         $hash->{$key} = $val;
  1712.     }
  1713.     return $hash;
  1714. }
  1715.  
  1716. ###
  1717. ### hash_merge
  1718. ###
  1719. ### Merges a second hash into a first
  1720. ###
  1721.  
  1722. sub hash_merge {
  1723.     my ($self, $newdata, $overwrite) = @_;
  1724.     foreach my $z (keys(%{$newdata})) {
  1725.         next if defined $self->{$z} && ! $overwrite;
  1726.         $self->{$z} = $newdata->{$z};
  1727.     }
  1728.     return $self;
  1729. }
  1730.  
  1731. ###
  1732. ### read_tree
  1733. ###
  1734. ### Reads in a tree file and returns results in a format that is easily manipulated
  1735. ### by the program.
  1736. ###
  1737.  
  1738. sub read_tree {
  1739.     my ($topic, $arg) = @_;
  1740.     undef my $resultref;
  1741.     undef my $file;
  1742.     if ($topic == 0) {
  1743.         $file = readfile("$DCONF->{admin_dir}/tree.txt", "read_tree", $arg);
  1744.     } else {
  1745.         $file = readfile("$DCONF->{admin_dir}/msg_index/$topic-tree.txt", "read_tree", $arg);
  1746.     }
  1747.     my @res_ref = ();
  1748.     foreach my $line (@{ $file }) {
  1749.         next if $line =~ /^#/;
  1750.         push @res_ref, tree_line_as_hash($line);
  1751.     }
  1752.     return \@res_ref;
  1753. }
  1754.  
  1755. ###
  1756. ### write_tree
  1757. ###
  1758. ### Writes out the tree file from the program's internal tree format.
  1759. ###
  1760.  
  1761. sub write_tree {
  1762.     my ($topic, $tree, $arg) = @_;
  1763.     my @output = ();
  1764.     foreach my $xref (@{ $tree }) {
  1765.         next if ! defined $xref->{page};
  1766.         my $r = (generate_tree_line($xref))[0];
  1767.         push (@output, $r) if defined $r;
  1768.     }
  1769.     if ($topic == 0) {
  1770.         writefile("$DCONF->{admin_dir}/tree.txt", \@output, "write_tree", $arg) if !$arg->{no_write};
  1771.     } else {
  1772.         writefile("$DCONF->{admin_dir}/msg_index/$topic-tree.txt", \@output, "write_tree", $arg) if !$arg->{no_write};
  1773.     }
  1774.     return \@output;
  1775. }
  1776.  
  1777. ###
  1778. ### trim
  1779. ###
  1780. ### Trims off leading and trailing spaces, and collapses multiple spaces
  1781. ### into one
  1782. ###
  1783.  
  1784. sub trim {
  1785.     my @o = ();
  1786.     while (scalar( @_ )) {
  1787.         my $s = shift @_;
  1788.         $s =~ s/^\s+//;
  1789.         $s =~ s/\s+$//;
  1790.         $s =~ s/\s+/ /g;
  1791.         push @o, $s;
  1792.     }
  1793.     return @o if scalar(@o) != 1;
  1794.     return $o[0];
  1795. }
  1796.  
  1797. ###
  1798. ### rename_file
  1799. ###
  1800. ### Renames a file, unless you're on NT, when it copies the old file and then
  1801. ### removes it ("rename" function doesn't get along well with NT).
  1802. ###
  1803.  
  1804. sub rename_file {
  1805.     my ($filename, $fsize_desired, $new_file_name) = @_;
  1806.     my ($fsize, $code, @file, $old_file, $new_file);
  1807.     if ($new_file_name ne "") {
  1808.         $old_file = $filename;
  1809.         $new_file = $new_file_name;
  1810.     } else {
  1811.         $old_file = "$filename.NEW";
  1812.         $new_file = $filename;
  1813.     }
  1814.     if (-e "$old_file") {
  1815.         $fsize = -s "$old_file";
  1816.         if ($fsize < $fsize_desired) {
  1817.             undef $!;
  1818.             unlink ("$old_file");
  1819.             if ($GLOBAL_OPTIONS->{'diskquota_disable'} == 1 || $GLOBAL_OPTIONS->{'diskquota_disable'} eq "") {
  1820.                 open (BACKUPS, ">$DCONF->{admin_dir}/backups/QUOTA.txt");
  1821.                 print BACKUPS time, "\n";
  1822.                 print BACKUPS escape("Write to $new_file: wrong size (expected: $fsize_desired; actual: $fsize"), "\n";
  1823.                 close (BACKUPS);
  1824.             }
  1825.             my $fn = ""; $fn = $' if $new_file =~ /.*\//;
  1826.             quota_err($fn, $fsize_desired, $fsize);
  1827.         }
  1828.         if (defined($DCONF->{NT}) || $DCONF->{platform} =~ m|NT|i) {
  1829.             $code = 0;
  1830.         } else {
  1831.             $code = rename("$old_file", "$new_file");
  1832.         }
  1833.         if ($code != 1 || !-e $new_file) {
  1834.             open (FILE, "$old_file");
  1835.             @file = <FILE>;
  1836.             close (FILE);
  1837.             open (FILE, ">$new_file");
  1838.             print FILE @file;
  1839.             close (FILE);
  1840.             $fsize = -s "$new_file";
  1841.             if ($fsize < $fsize_desired) {
  1842.                 unlink($new_file);
  1843.                 if ($GLOBAL_OPTIONS->{'diskquota_disable'} == 1 || $GLOBAL_OPTIONS->{'diskquota_disable'} eq "") {
  1844.                     open (BACKUPS, ">$DCONF->{admin_dir}/backups/QUOTA.txt");
  1845.                     print BACKUPS time, "\n";
  1846.                     print BACKUPS escape("Write to $new_file: wrong size (expected: $fsize_desired; actual: $fsize"), "\n";
  1847.                     close (BACKUPS);
  1848.                 }
  1849.                 my $fn = ""; $fn = $' if $new_file =~ /.*\//;
  1850.                 quota_err($fn, $fsize_desired, $fsize);
  1851.             }
  1852.             unlink ("$old_file");
  1853.         }
  1854.         chmod (oct($DCONF->{perms0666}), $new_file);
  1855.     } else {
  1856.         error_message("File Save - Write Error", "Could not open $old_file for reading.") if $fsize_desired != -1;
  1857.     }
  1858.     return 1;
  1859. }
  1860.  
  1861. ###
  1862. ### get_date_time
  1863. ###
  1864. ### Converts from a numerical time stamp to a human-readable time, based on language.conf
  1865. ### parameters and supplied desired format.
  1866. ###
  1867.  
  1868. sub get_date_time {
  1869.     my ($format, $timer, $block_tz) = @_;
  1870.     $timer = time if $timer == 0;
  1871.     $timer += ($GLOBAL_OPTIONS->{'timezone'}*3600) if $block_tz != 591;
  1872.     my ($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst);
  1873.     if ($GLOBAL_OPTIONS->{'usegmtime'} == 1) {
  1874.         ($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst) = gmtime($timer);
  1875.     } else {
  1876.         ($sec, $min, $hour, $day, $nmonth, $year, $wday, $yday, $isdst) = localtime($timer);
  1877.     }
  1878.     my $ampm = "";
  1879.     my $twentyfour_hour = $hour;
  1880.     if (read_language()->{HRCLOCK} == 12) {
  1881.         if ($hour > 12) {
  1882.             $hour -= 12; $ampm = read_language()->{PM};
  1883.         } elsif ($hour == 12) {
  1884.             $ampm = read_language()->{PM};
  1885.         } else {
  1886.             $ampm = read_language()->{AM};
  1887.         }
  1888.         $hour = 12 if $hour == 0;
  1889.     }
  1890.     $year += 1900;
  1891.     my $lt_year = sprintf "%02d", $year % 100;
  1892.     my $week = (@{ read_language()->{DAY} })[$wday];
  1893.     my $month = (@{ read_language()->{MONTH} })[$nmonth];
  1894.     my $month_abbr = (@{ read_language()->{MONTH_ABBR} })[$nmonth];
  1895.     my $day_abbr = (@{ read_language()->{ABBRDAY} })[$wday];
  1896.     my $hour_format_string = $GLOBAL_OPTIONS->{dates_hour_zero} == 1 ? "%02d" : "%d";
  1897.     my $month_format_string = $GLOBAL_OPTIONS->{dates_month_zero} == 1 ? "%02d" : "%d";
  1898.     my $day_format_string = $GLOBAL_OPTIONS->{dates_zero} == 1 ? "%02d" : "%d";
  1899.     my $HOUR = sprintf $hour_format_string, $hour;
  1900.     my $T24HOUR = sprintf $hour_format_string, $twentyfour_hour;
  1901.     my $MONTH = sprintf $month_format_string, 1+$nmonth;
  1902.     my $DAY = sprintf $day_format_string, $day;
  1903.     $min = sprintf "%02d", $min;
  1904.     $sec = sprintf "%02d", $sec;
  1905.     my $ls = "";
  1906.     if ($format =~ m|\%|) {
  1907.         $ls = $format;
  1908.     } else {
  1909.         my $lookups = {
  1910.             long => read_language()->{LONGDATE},
  1911.             short => read_language()->{SHORTDATE},
  1912.             shorter => (defined read_language()->{SHORTERDATE} ? read_language()->{SHORTERDATE} : read_language()->{SHORTDATE}),
  1913.             message => (defined read_language()->{MESSAGEDATE} ? read_language()->{MESSAGEDATE} : read_language()->{LONGDATE}),
  1914.             realshort => read_language()->{REALSHORTDATE},
  1915.             dateonly => read_language()->{DATEONLY},
  1916.         };
  1917.         $ls = $lookups->{$format};
  1918.     }
  1919.     $ls =~ s/\%weekday/$week/g;
  1920.     $ls =~ s/\%wkdy\./$day_abbr/g;
  1921.     $ls =~ s/\%hour/$HOUR/g;
  1922.     $ls =~ s/\%minute/$min/g;
  1923.     $ls =~ s/\%month/$month/g;
  1924.     $ls =~ s/\%mon\./$month_abbr/g;
  1925.     my $mabbr2 = $month_abbr; $mabbr2 =~ s/\.//g;
  1926.     $ls =~ s/\%mon_/$mabbr2/g;
  1927.     my $dabbr2 = $day_abbr; $dabbr2 =~ s/\.//g;
  1928.     $ls =~ s/\%wkdy_/$dabbr2/g;
  1929.     $ls =~ s/\%nmonth/$MONTH/g;
  1930.     $ls =~ s/\%year/$year/g;
  1931.     $ls =~ s/\%ampm/$ampm/g;
  1932.     $ls =~ s/\%second/$sec/g;
  1933.     $ls =~ s/\%day/$DAY/g;
  1934.     $ls =~ s/\%24hour/$T24HOUR/g;
  1935.     $ls =~ s/\%2year/$lt_year/g;
  1936.     $ls =~ s/\s+$//;
  1937.     return $ls;
  1938. }
  1939.  
  1940. ###
  1941. ### screen_out
  1942. ###
  1943. ### Writes a screen from a template
  1944. ###
  1945.  
  1946. sub screen_out {
  1947.     my ($screen, $subst, $cookie, $escape) = @_;
  1948.     $subst->{DYNAMIC}->{server_time} = time;
  1949.     dreq("template");
  1950.     header($cookie);
  1951.     print templ_int($screen, $subst);
  1952.     return 1 if $escape;
  1953.     print "<!--HTTP Cookie: $ENV{HTTP_COOKIE} -->\n";
  1954.     print "<!--Setting Cookies:\n $cookie -->\n";
  1955.     program_exit(0);
  1956. }
  1957.  
  1958. ###
  1959. ### keyspew
  1960. ###
  1961. ### Converts a hash into a string
  1962. ###
  1963.  
  1964. sub keyspew {
  1965.     my ($hash) = @_;
  1966.     my @x = ();
  1967.     foreach my $k (sort keys(%{ $hash })) {
  1968.         push @x, join("=>", $k, $hash->{$k});
  1969.     }
  1970.     return join(" ", @x);
  1971. }
  1972.  
  1973. ###
  1974. ### readfile
  1975. ###
  1976. ### Low-level file reader (includes locking functions)
  1977. ###
  1978.  
  1979. sub readfile {
  1980.     my ($file, $caller, $args) = @_;
  1981.     my @tellresult = ();
  1982.     my @array = ();
  1983.     $file =~ m|(.*)/|;
  1984.     my $shortfile = $';
  1985.     lock($file) if !$args->{no_lock};
  1986.     performance_string("< readfile for $caller on $file: ", keyspew($args)) if $GLOBAL_OPTIONS->{performance_monitoring};
  1987.     $PARAMS->{files_read}++;
  1988.     $PARAMS->{file_access}->{$file}->{read} += 1;
  1989.     $PARAMS->{file_access}->{$file}->{write} += 0;
  1990.     if (open (READFILE, "< $file")) {
  1991.         if ($args->{'tell'}) {
  1992.             binmode READFILE;
  1993.             while (<READFILE>) {
  1994.                 push @tellresult, (tell READFILE) - length($_);
  1995.                 s/\r\n$/\n/;
  1996.                 push @array, $_;
  1997.             }
  1998.             close (READFILE);
  1999.         } else {
  2000.             @array = <READFILE>;
  2001.             close (READFILE);
  2002.         }
  2003.     } else {
  2004.         if ($args->{create}) {
  2005.             @array = ();
  2006.         } else {
  2007.             error_message("Open[r] file error", "Couldn't open file [$shortfile] for [$caller]!");
  2008.         }
  2009.     }
  2010.     unlock($file) if !$args->{no_unlock};
  2011.     unlink $file if $args->{delfile};
  2012.     @array = grep(/\S/, @array);
  2013.     if (!$args->{ok_zero} && !$args->{zero_ok} && !$args->{create} && scalar(@array) == 0) {
  2014.         error_message("Open[r] file error", "File [$shortfile] has zero length in reading for [$caller]!", 0, 1);
  2015.     }
  2016.     return \@array if $args->{'tell'} == 0;
  2017.     return (\@array, \@tellresult);
  2018. }
  2019.  
  2020. ###
  2021. ### touch_createfile
  2022. ###
  2023. ### Creates a blank file if it doesn't exist already
  2024. ###
  2025.  
  2026. sub touch_createfile {
  2027.     my ($filename, $deleteit) = @_;
  2028.     return 1 if $deleteit == 0 && -e $filename;
  2029.     if (open(FILE, "> $filename")) {
  2030.         close (FILE);
  2031.         chmod(oct($DCONF->{perms0666}), $filename);
  2032.         return 1;
  2033.     } else {
  2034.         return 0;
  2035.     }
  2036. }
  2037.  
  2038. ###
  2039. ### readfile_binary
  2040. ###
  2041. ### Reads a single string of information into a file
  2042. ###
  2043.  
  2044. sub readfile_binary {
  2045.     my ($file) = @_;
  2046.     performance_string("< readfile_binary on $file") if $GLOBAL_OPTIONS->{performance_monitoring};
  2047.     $PARAMS->{file_access}->{$file}->{read} += 1;
  2048.     $PARAMS->{file_access}->{$file}->{write} += 0;
  2049.     my $tmp = $/;
  2050.     undef $/;
  2051.     if (open(FILE, "< $file")) {
  2052.         binmode(FILE);
  2053.         my $data = <FILE>;
  2054.         close (FILE);
  2055.         $/ = $tmp;
  2056.         return $data;
  2057.     }
  2058.     $/ = $tmp;
  2059.     return undef;
  2060. }
  2061.  
  2062. ###
  2063. ### writefile_binary
  2064. ###
  2065. ### Writes a single string of information into a file
  2066. ###
  2067.  
  2068. sub writefile_binary {
  2069.     my ($file, $data) = @_;
  2070.     performance_string("> writefile_binary on $file, data size ", length($data)) if $GLOBAL_OPTIONS->{performance_monitoring};
  2071.     $PARAMS->{files_written}++;
  2072.     $PARAMS->{file_access}->{$file}->{read} += 0;
  2073.     $PARAMS->{file_access}->{$file}->{write} += 1;
  2074.     if (open(FILE, "> $file")) {
  2075.         binmode (FILE);
  2076.         print FILE $data;
  2077.         close (FILE);
  2078.         return 1;
  2079.     } else {
  2080.         return 0;
  2081.     }
  2082. }
  2083.  
  2084. ###
  2085. ### writefile
  2086. ###
  2087. ### Low-level file writer (includes locking functions and verification that part of
  2088. ### the file wasn't lost due to a disk quota condition)
  2089. ###
  2090.  
  2091. sub writefile {
  2092.     my ($file, $data, $caller, $args) = @_;
  2093.     $file =~ m|(.*)/|;
  2094.     my $shortfile = $';
  2095.     my $unique_string = join("", time, $ENV{'REMOTE_ADDR'}, $$);
  2096.     $unique_string =~ s/\D//g;
  2097.     my $str = "";
  2098.     $str = ( ref $data eq "ARRAY" ? join("\n", @{$data}) : $data );
  2099.     if (ref $data eq "ARRAY") {
  2100.         $str =~ s/\r//g; $str =~ s/\n+/\n/g;
  2101.     }
  2102.     my $exp_len = length($str);
  2103.     performance_string("> writefile for $caller on $file, data size $exp_len: ", keyspew($args)) if $GLOBAL_OPTIONS->{performance_monitoring};
  2104.     $PARAMS->{file_access}->{$file}->{write}++;
  2105.     $PARAMS->{files_written}++;
  2106.     $PARAMS->{file_access}->{$file}->{read} += 0;
  2107.     lock($file) if !$args->{no_lock};
  2108.     $args->{no_backup} = 1 if $GLOBAL_OPTIONS->{quota_check_off};
  2109.     if (!$args->{no_backup}) {
  2110.         open (FILE, "> $DCONF->{admin_dir}/backups/$unique_string-$shortfile") || error_message("Open[w] file error", "Couldn't open temporary file backups/$unique_string-$shortfile for [$caller]!");
  2111.         binmode(FILE);
  2112.         print FILE $str;
  2113.         close (FILE);
  2114.         my $size1 = -s "$DCONF->{admin_dir}/backups/$unique_string-$shortfile";
  2115.         performance_string("   Backup file write for backups/$unique_string-$shortfile, size $size1 (expected $exp_len)") if $GLOBAL_OPTIONS->{performance_monitoring};
  2116.         quota_err($shortfile, $exp_len, $size1) if $exp_len > $size1;
  2117.     }
  2118.     open (FILE, "> $file") || error_message("Open[w] file error", "Couldn't open file [$shortfile] for update for [$caller]!");
  2119.     binmode(FILE);
  2120.     print FILE $str;
  2121.     close (FILE);
  2122.     performance_string("   Wrote $file for $caller, size ", -s $file) if $GLOBAL_OPTIONS->{performance_monitoring};
  2123.     chmod (oct($DCONF->{perms0666}), $file);
  2124.     unlock($file) if !$args->{no_unlock};
  2125.     if (!$args->{no_sizecheck} && !$GLOBAL_OPTIONS->{quota_check_off}) {
  2126.         my $size2 = -s $file;
  2127.         quota_err($shortfile, $exp_len, $size2) if $exp_len > $size2;
  2128.     }
  2129.     if (!$args->{no_backup}) {
  2130.         unlink("$DCONF->{admin_dir}/backups/$unique_string-$shortfile") || quota_err($shortfile, -1, undef);
  2131.         performance_string("   Removed backup file backups/$unique_string-$shortfile") if $GLOBAL_OPTIONS->{performance_monitoring};
  2132.     }
  2133.     return $exp_len;
  2134. }
  2135.  
  2136. ###
  2137. ### appendfile
  2138. ###
  2139. ### Low-level file appender
  2140. ###
  2141.  
  2142. sub appendfile {
  2143.     my ($file, $data, $caller, $args) = @_;
  2144.     performance_string(">> appendfile for $caller on $file: ", keyspew($args)) if $GLOBAL_OPTIONS->{performance_monitoring};
  2145.     $PARAMS->{file_access}->{$file}->{write}++;
  2146.     $PARAMS->{file_access}->{$file}->{read} += 0;
  2147.     $PARAMS->{files_written}++;
  2148.     $file =~ m|(.*)/|; my $shortfile = $';
  2149.     lock($file) if !$args->{no_lock};
  2150.     open (FILE, ">> $file") || error_message("Open[a] file error", "Couldn't open file [$shortfile] for append for [$caller]!");
  2151.     print FILE @{$data};
  2152.     close (FILE);
  2153.     unlock($file) if !$args->{no_unlock};
  2154.     return 1;
  2155. }
  2156.  
  2157. ###
  2158. ### maintenance_mode_error
  2159. ###
  2160. ### Error message for when the board is in maintenance mode
  2161. ###
  2162.  
  2163. sub maintenance_mode_error {
  2164.     error_message(read_language()->{MAINTENANCE_MODE_HEADER}, read_language()->{MAINTENANCE_MODE_EXPL}, 0, 1);
  2165. }
  2166.  
  2167. ###
  2168. ### quota_err
  2169. ###
  2170. ### Error message when disk quota is exceeded
  2171. ###
  2172.  
  2173. sub quota_err {
  2174.     my ($filename, $expected_length, $actual_length) = @_;
  2175.     my $e1 = read_language()->{QUOTA_CONDITION};
  2176.     my $e2 = read_language()->{DISK_QUOTA_ERROR};
  2177.     if ($filename ne "") {
  2178.         $e2 .= "<p><font face=\"courier new\" size=2>$filename<br>$expected_length<br>$actual_length</font></p>";
  2179.     }
  2180.     error_message($e1, $e2, 0, 1);
  2181. }
  2182.  
  2183. ###
  2184. ### board_topics
  2185. ###
  2186. ### Reads topics on board and returns a conveniently manipulated array containing
  2187. ### parameters of each topic.  This handles version 3.00+ topic files (and maybe
  2188. ### past versions too -- untested).
  2189. ###
  2190.  
  2191. sub board_topics {
  2192.     my ($argument, $file, $tree, $noerr, $nolock) = @_;
  2193.     if (! defined $tree) {
  2194.         $tree = readfile("$DCONF->{admin_dir}/tree.txt", "board_topics", { zero_ok => 1}) if ! $nolock;
  2195.         $tree = readfile("$DCONF->{admin_dir}/tree.txt", "board_topics", { no_lock => 1, no_unlock => 1, zero_ok => 1}) if $nolock;
  2196.     }
  2197.     undef my $array;
  2198.     foreach my $tl (@{$tree}) {
  2199.         undef my $hash;
  2200.         if ($hash = tree_line_as_hash($tl)) {
  2201.             if ($hash->{topic} == $argument && $argument > 0) {
  2202.                 return $hash;
  2203.             }
  2204.             $array->{ $hash->{topic} } = $hash;
  2205.         }
  2206.     }
  2207.     if (! defined($file)) {
  2208.         my $lockstuff = $nolock == 1 ? { no_lock => 1, no_unlock => 1 } : {} ;
  2209.         if (! $DCONF->{pro} || (! $GLOBAL_OPTIONS->{secure_topics_file} && ! $GLOBAL_OPTIONS->{topics_to_show})) {
  2210.             return [] if $noerr && (! -e "$DCONF->{message_dir}/$DCONF->{board_topics_file}" || -s "$DCONF->{message_dir}/$DCONF->{board_topics_file}" == 0);
  2211.             $file = readfile("$DCONF->{message_dir}/$DCONF->{board_topics_file}", "board_topics", $lockstuff);
  2212.         } else {
  2213.             return [] if $noerr && (! -e "$DCONF->{secdir}/$DCONF->{board_topics_file}" || -s "$DCONF->{secdir}/$DCONF->{board_topics_file}" == 0);
  2214.             $argument = hash_merge($argument, $lockstuff, 1);
  2215.             dreq("authwrap-PRO");
  2216.             $file = wrapped_topics_file($argument);
  2217.         }
  2218.     }
  2219.     my @array = ();
  2220.     my $flag = 0;
  2221.     my @these = ();
  2222.     foreach my $fline (@{$file}) {
  2223.         next if $flag == 0 && $fline !~ m|^<!-|;
  2224.         if ($fline =~ m|^<!--?Top: (\d+)-[!\-]>|) {
  2225.             push @array, _board_topics_topic(\@these, $array) if $flag == 1;
  2226.             push @array, _board_topics_cat(\@these, $array) if $flag == 2;
  2227.             @these = ($fline);
  2228.             $flag = 1;
  2229.         } elsif ($fline =~ m|^<!--Category: (\d+)-->|) {
  2230.             push @array, _board_topics_topic(\@these, $array) if $flag == 1;
  2231.             push @array, _board_topics_cat(\@these, $array) if $flag == 2;
  2232.             @these = ($fline);
  2233.             $flag = 2;
  2234.         } elsif ($fline =~ m|<!--/Top-->| || $fline =~ m|<!--/Category-->| || $fline =~ m|<!--End Topics-->|) {
  2235.             push @these, $fline;
  2236.             push @array, _board_topics_topic(\@these, $array) if $flag == 1;
  2237.             push @array, _board_topics_cat(\@these, $array) if $flag == 2;
  2238.             $flag = 0;
  2239.             last if $fline =~ m|<!--End Topics-->|;
  2240.             @these = ();
  2241.         } elsif ($flag > 0) {
  2242.             push @these, $fline;
  2243.         }
  2244.     }
  2245.     push @array, _board_topics_topic(\@these, $array) if $flag == 1;
  2246.     push @array, _board_topics_cat(\@these, $array) if $flag == 2;
  2247.     return \@array;
  2248. }
  2249.  
  2250. sub _board_topics_topic {
  2251.     my ($these, $array) = @_;
  2252.     my $fline = join("", @{$these});
  2253.     $fline =~ s/\r\n/ /g;
  2254.     $fline =~ s/\r/ /g;
  2255.     $fline =~ s/\n/ /g;
  2256.     my $href = {};
  2257.     if ($fline =~ m|<!--?Top: (\d+)-[!\-]>|) {
  2258.         my $tn = $1;
  2259.         $href->{number} = $tn;
  2260.         if (defined($array->{$tn})) {
  2261.             foreach my $x ('name', 'params', 'posts', 'properties', 'lastmod', 'subs', 'last_poster') {
  2262.                 $href->{$x} = ( $array->{$tn}->{$x} ne "" ? $array->{$tn}->{$x} : " ");
  2263.             }
  2264.         } else {
  2265.             $href = extract_info($href->{number}, $href->{number}, { no_error => 1 });
  2266.             $href->{'lastmod'} = "0";
  2267.             $href->{'posts'} = "?";
  2268.             $href->{'subs'} = "?";
  2269.             $href->{'originator'} = "";
  2270.             $href->{'last_poster'} = "";
  2271.         }
  2272.         foreach my $y (split(/;/, $href->{properties})) {
  2273.             $y =~ s/\s//g;
  2274.             my ($y1, $y2) = split(/=/, $y, 2);
  2275.             $href->{'props'}->{$y1} = $y2;
  2276.         }
  2277.         $href->{icon} = (defined($href->{props}->{icon}) ? $href->{props}->{icon} : "tree_n");
  2278.         $href->{hidden} = $href->{props}->{hidden};
  2279.         $href->{type} = 1;
  2280.         $href->{descr} = $1 if ($fline =~ m|<!--?Descr-[!\-]>(.*?)<!--?/Descr-[!\-]>|);
  2281.         if (-e "$DCONF->{message_dir}/$tn") {
  2282.             $href->{secure} = 0;
  2283.             $href->{url} = "$DCONF->{message_url}/$tn/$tn.$DCONF->{ext}";
  2284.             $href->{url} .= "?$href->{lastmod}" if !$DCONF->{noqm};
  2285.         } else {
  2286.             $href->{secure} = 1;
  2287.             $href->{url} = "$DCONF->{authorize_reader}?file=/$tn/$tn.$DCONF->{ext}&lm=$href->{lastmod}";
  2288.         }
  2289.     }
  2290.     return $href;
  2291. }
  2292.  
  2293. sub _board_topics_cat {
  2294.     my ($these, $array) = @_;
  2295.     my $fline = join("", @{$these});
  2296.     $fline =~ s/\r\n/ /g;
  2297.     $fline =~ s/\r/ /g;
  2298.     $fline =~ s/\n/ /g;
  2299.     my $cref = {};
  2300.     if ($fline =~ m|^<!--Category: (\d+)-->|) {
  2301.         my $cn = $1;
  2302.         $cref->{number} = $cn;
  2303.         $cref->{text} = $1 if $fline =~ m|<!--Text-->(.*?)<!--/Text-->|;
  2304.         $cref->{descr} = $1 if $fline =~ m|<!--Descr-->(.*?)<!--/Descr-->|;
  2305.         $cref->{descr} = "" if $cref->{descr} !~ /\S/;
  2306.         $cref->{bgcolor} = $1 if $fline =~ m|<!--bgcolor:(.*?)-->|;
  2307.         $cref->{type} = 2;
  2308.     }
  2309.     return $cref;
  2310. }
  2311.  
  2312. ###
  2313. ### makeord
  2314. ###
  2315. ### Conversion of characters to their HTML equivalents if charconvert.conf
  2316. ### is not functioning.
  2317. ###
  2318.  
  2319. sub makeord {
  2320.     my ($o, $num) = @_;
  2321.     if (ord($o) <= 126 || ord($o) == 255) {
  2322.         $num = ord($o);
  2323.         return "&#$num;";
  2324.     } else {
  2325.         return $o;
  2326.     }
  2327. }
  2328.  
  2329. ###
  2330. ### remove_html
  2331. ###
  2332. ### Removes HTML code from text
  2333. ###
  2334.  
  2335. sub remove_html {
  2336.     my ($string, $flag) = @_;
  2337.     $string =~ s/<IMG SRC="[^"]*" ALT="([^"]*)"[^>]*>/\[$1\]/gi;
  2338.     $string =~ s/<[^>]*>//g;
  2339.     $string =~ s/&#(\d+);//g if $flag == 0;
  2340.     return $string;
  2341. }
  2342.  
  2343. ###
  2344. ### alpha_sort
  2345. ###
  2346. ### Case-insensitive alphabetical sort
  2347. ###
  2348.  
  2349. sub alpha_sort {
  2350.     my ($_a, $_b) = (lc(trim($a->{name})), lc(trim($b->{name})));
  2351.     return $_a cmp $_b;
  2352. }
  2353.  
  2354. ###
  2355. ### get_number
  2356. ###
  2357. ### Generates a new unique index from the data.txt file
  2358. ###
  2359.  
  2360. sub get_number {
  2361.     my ($lock_arg) = @_;
  2362.     return sql_counter_increment("data", $lock_arg) if $GLOBAL_OPTIONS->{database};
  2363.     my $fref = readfile("$DCONF->{admin_dir}/data.txt", "get_number", { no_unlock => 1, no_lock => 0+$lock_arg });
  2364.     my $num = $fref->[0]; chomp $num; $num += 1;
  2365.     writefile("$DCONF->{admin_dir}/data.txt", [ $num ], "get_number", { no_lock => 1, no_unlock => 0+$lock_arg });
  2366.     return $num;
  2367. }
  2368.  
  2369. ###
  2370. ### sql_counter_increment
  2371. ###
  2372. ### Increments a counter in MySQL database and returns the value
  2373. ###
  2374.  
  2375. sub sql_counter_increment {
  2376.     my ($counter, $lock_arg) = @_;
  2377.     my $counter_lookup = { data => 1, postindex => 2 };
  2378.     lock("sql_counter_increment", "$DCONF->{admin_dir}/$counter.txt") if ! $lock_arg;
  2379.     db_query("UPDATE $PARAMS->{db_prefix}counters SET value = value + 1 WHERE ID = ?;", undef, 0, [$counter_lookup->{$counter}]);
  2380.     my $val = db_sql_query(undef, "counters", "select", { ID => $counter_lookup->{$counter} }, undef);
  2381.     unlock("sql_counter_increment", "$DCONF->{admin_dir}/$counter.txt") if ! $lock_arg;
  2382.     return $val->[0]->{value};
  2383. }
  2384.  
  2385. 1;
  2386.