1###############################################################################
2# Subs.pm                                                                     #
3# $Date: 12.02.14 $                                                           #
4###############################################################################
5# YaBB: Yet another Bulletin Board                                            #
6# Open-Source Community Software for Webmasters                               #
7# Version:        YaBB 2.6.11                                                 #
8# Packaged:       December 2, 2014                                            #
9# Distributed by: http://www.yabbforum.com                                    #
10# =========================================================================== #
11# Copyright (c) 2000-2014 YaBB (www.yabbforum.com) - All Rights Reserved.     #
12# Software by:  The YaBB Development Team                                     #
13#               with assistance from the YaBB community.                      #
14###############################################################################
15# use strict;
16# use warnings;
17no warnings qw(uninitialized once redefine);
18use CGI::Carp qw(fatalsToBrowser);
19use English qw(-no_match_vars);
20our $VERSION = '2.6.11';
21
22$subspmver = 'YaBB 2.6.11 $Revision: 1611 $';
23
24use subs 'exit';
25
26$yymain       = q{};
27$yyjavascript = q{};
28$langopt      = q{};
29
30# set line wrap limit in Display.
31$linewrap = 80;
32$newswrap = 0;
33
34# get the current date/time
35
36$date = int( time() + $timecorrection );
37
38# check if browser accepts encoded output
39$gzaccept = $ENV{'HTTP_ACCEPT_ENCODING'} =~ /\bgzip\b/sm || $gzforce;
40
41# parse the query string
42readform();
43
44$uid = substr $date, length($date) - 3, 3;
45$session_id = $cookiesession_name;
46
47$randaction = substr $date, 0, length($date) - 2;
48
49$user_ip = $ENV{'REMOTE_ADDR'};
50if ( $user_ip eq '127.0.0.1' ) {
51    if ( $ENV{'HTTP_CLIENT_IP'} && $ENV{'HTTP_CLIENT_IP'} ne '127.0.0.1' ) {
52        $user_ip = $ENV{'HTTP_CLIENT_IP'};
53    }
54    elsif ( $ENV{'X_CLIENT_IP'} && $ENV{'X_CLIENT_IP'} ne '127.0.0.1' ) {
55        $user_ip = $ENV{'X_CLIENT_IP'};
56    }
57    elsif ($ENV{'HTTP_X_FORWARDED_FOR'}
58        && $ENV{'HTTP_X_FORWARDED_FOR'} ne '127.0.0.1' )
59    {
60        $user_ip = $ENV{'HTTP_X_FORWARDED_FOR'};
61    }
62}
63
64if   ( -e "$yyexec.cgi" ) { $yyext = 'cgi'; }
65else                      { $yyext = 'pl'; }
66if   ( -e 'AdminIndex.cgi' ) { $yyaext = 'cgi'; }
67else                         { $yyaext = 'pl'; }
68
69sub automaintenance {
70    my ( $maction, $mreason ) = @_;
71    if ( lc($maction) eq 'on' ) {
72        fopen( MAINT, ">$vardir/maintenance.lock" );
73        print {MAINT}
74          qq~$maintxt{'maint'}\n~
75          or croak qq~$maintxt{'maint'}~;
76        fclose(MAINT);
77        if ( $mreason eq 'low_disk' ) {
78            LoadLanguage('Error');
79            alertbox( $error_txt{'low_diskspace'} );
80        }
81        if ( !$maintenance ) { $maintenance = 2; }
82    }
83    elsif ( lc($maction) eq 'off' ) {
84        unlink "$vardir/maintenance.lock"
85          or fatal_error( 'cannot_open_dir', "$vardir/maintenance.lock" );
86        if ( $maintenance == 2 ) { $maintenance = 0; }
87    }
88    return;
89}
90
91sub getnewid {
92    my $newid = $date;
93    while ( -e "$datadir/$newid.txt" ) { ++$newid; }
94    return $newid;
95}
96
97sub undupe {
98    my (@indup) = @_;
99    my ( @out, $duped, );
100    foreach my $check (@indup) {
101        $duped = 0;
102        foreach (@out) {
103            if ( $_ eq $check ) { $duped = 1; last; }
104        }
105        if ( !$duped ) { push @out, $check; }
106    }
107    return @out;
108}
109
110sub exit {
111    my ($inexit)                = @_;
112    my $OUTPUT_AUTOFLUSH        = 1;
113    my $OUTPUT_RECORD_SEPARATOR = q{};
114    print q{};
115    if ($child_pid) { wait; }
116    CORE::exit( $inexit || 0 );
117    return;
118}
119
120sub print_output_header {
121    if ($header_already_printed) { return; }
122    $yyxml_lang = $abbr_lang;
123    $header_already_printed = 1;
124    $headerstatus ||= '200 OK';
125    $contenttype  ||= 'text/html';
126
127    my $ret = $yyIIS ? "HTTP/1.0 $headerstatus\n" : "Status: $headerstatus\n";
128
129    foreach ( $yySetCookies1, $yySetCookies2, $yySetCookies3, @otherCookies ) {
130        if ($_) { $ret .= "Set-Cookie: $_\n"; }
131    }
132
133    if ( !$no_error_page ) {
134        if ($yySetLocation) {
135            $ret .= "Location: $yySetLocation";
136        }
137        else {
138            if ( !$cachebehaviour ) {
139                $ret .=
140"Cache-Control: no-cache, must-revalidate\nPragma: no-cache\n";
141            }
142            if ($ETag)         { $ret .= "ETag: \"$ETag\"\n"; }
143            if ($LastModified) { $ret .= "Last-Modified: $LastModified\n"; }
144            if ( $gzcomp && $gzaccept ) { $ret .= "Content-Encoding: gzip\n"; }
145            $ret .= "Content-Type: $contenttype";
146            if ($yycharset) {$yymycharset = $yycharset;}
147            if ($yymycharset) { $ret .= "; charset=$yymycharset"; }
148       }
149    }
150    print $ret . "\r\n\r\n" or croak "$croak{'print'} ret";
151    return;
152}
153
154sub print_HTML_output_and_finish {
155    if ( $gzcomp && $gzaccept ) {
156        my $filehandle_exists = fileno GZIP;
157        if ( $gzcomp == 1 || $filehandle_exists ) {
158            $OUTPUT_AUTOFLUSH = 1;
159            if ( !$filehandle_exists ) {
160                open GZIP, '| gzip -f' or croak "$croak{'open'} GZIP";
161            }
162            print {GZIP} $output or croak "$croak{'print'} GZIP";
163            close GZIP or croak "$croak{'close'}";
164        }
165        else {
166            require Compress::Zlib;
167            binmode STDOUT;
168            print Compress::Zlib::memGzip($output)
169              or croak "$croak{'print'} ZLib";
170        }
171    }
172    else {
173        print $output;    # or croak "$croak{'print'} output";
174    }
175    exit;
176}
177
178sub write_cookie {
179    my %params = @_;
180
181    if ( $params{'-expires'} =~ /\+(\d+)m/xsm ) {
182        my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) =
183          gmtime( $date + $1 * 60 );
184
185        $year += 1900;
186        my @mos = qw(
187          Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec
188        );
189        my @dys = qw( Sun Mon Tue Wed Thu Fri Sat );
190        $mon  = $mos[$mon];
191        $wday = $dys[$wday];
192
193        $params{'-expires'} = sprintf '%s, %02i-%s-%04i %02i:%02i:%02i GMT',
194          $wday, $mday, $mon, $year, $hour, $min, $sec;
195    }
196
197    if ( $params{'-path'} ) { $params{'-path'} = " path=$params{'-path'};"; }
198    if ( $params{'-expires'} ) {
199        $params{'-expires'} = " expires=$params{'-expires'};";
200    }
201
202    return
203      "$params{'-name'}=$params{'-value'};$params{'-path'}$params{'-expires'}";
204}
205
206sub redirectexit {
207    $headerstatus = '302 Moved Temporarily';
208    print_output_header();
209    exit;
210}
211
212sub redirectmove {
213    require Sources::MessageIndex;
214    MessageIndex();
215    return;
216}
217
218sub redirectinternal {
219    if ($currentboard) {
220        if   ( $INFO{'num'} ) { require Sources::Display;      Display(); }
221        else                  { require Sources::MessageIndex; MessageIndex(); }
222    }
223    else {
224        require Sources::BoardIndex;
225        BoardIndex();
226    }
227    return;
228}
229
230sub ImgLoc {
231    @img = @_;
232    if ( exists $img_locs{ $img[0] } ) {
233        $img_locs{ $img[0] } = $img_locs{ $img[0] };
234    }
235    elsif ( -e "$htmldir/Templates/Forum/$useimages/$img[0]" ) {
236        $img_locs{ $img[0] } = qq~$imagesdir/$img[0]~;
237    }
238    else {
239        $img_locs{ $img[0] } = qq~$defaultimagesdir/$img[0]~;
240    }
241    return $img_locs{ $img[0] };
242}
243
244sub template {
245    print_output_header();
246
247    if ( $yytitle ne $maintxt{'error_description'} ) {
248        if ( ( !$iamguest || ( $iamguest && $guestaccess == 1 ) )
249            && !$maintenance )
250        {
251            $yyforumjump = jumpto();
252        }
253        else { $yyforumjump = ' '; }
254    }
255    $yyposition      = $yytitle;
256    $yytitle         = "$mbname - $yytitle";
257    $yyimages        = $imagesdir;
258    $yydefaultimages = $defaultimagesdir;
259    $yysyntax_js     = q{};
260    $yygreyboxstyle  = q{};
261    $yygrayscript    = q{};
262
263    if (
264           $INFO{'num'}
265        || $action eq 'post'
266        || $action eq 'modify'
267        || $action eq 'preview'
268        || $action eq 'search2'
269        || $action eq 'imshow'
270        || $action eq 'imsend'
271        || $action eq 'myviewprofile'
272        || $action eq 'eventcal'
273        || $action eq 'help'
274        || $action eq 'recenttopics'
275        || $action eq 'recent'
276        || $action eq 'usersrecentposts'
277        || $action eq 'myusersrecentposts'
278       )
279    {
280        $yysyntax_js = qq~
281<script type="text/javascript" src="$yyhtml_root/shjs/sh_main.js"></script>
282<script type="text/javascript" src="$yyhtml_root/shjs/sh_cpp.js"></script>
283<script type="text/javascript" src="$yyhtml_root/shjs/sh_css.js"></script>
284<script type="text/javascript" src="$yyhtml_root/shjs/sh_html.js"></script>
285<script type="text/javascript" src="$yyhtml_root/shjs/sh_java.js"></script>
286<script type="text/javascript" src="$yyhtml_root/shjs/sh_javascript.js"></script>
287<script type="text/javascript" src="$yyhtml_root/shjs/sh_pascal.js"></script>
288<script type="text/javascript" src="$yyhtml_root/shjs/sh_perl.js"></script>
289<script type="text/javascript" src="$yyhtml_root/shjs/sh_php.js"></script>
290<script type="text/javascript" src="$yyhtml_root/shjs/sh_sql.js"></script>
291~;
292        $yyjsstyle =
293qq~<link rel="stylesheet" href="$yyhtml_root/shjs/styles/sh_style.css" type="text/css" />\n~;
294        $yyhigh = q~<script type="text/javascript">
295    sh_highlightDocument();
296</script>~;
297
298        if ($img_greybox) {
299            $yygreyboxstyle =
300qq~<link href="$yyhtml_root/greybox/gb_styles.css" rel="stylesheet" type="text/css" />\n~;
301
302            $yygrayscript = qq~
303<script type="text/javascript">
304    var GB_ROOT_DIR = "$yyhtml_root/greybox/";
305</script>
306<script type="text/javascript" src="$yyhtml_root/AJS.js"></script>
307<script type="text/javascript" src="$yyhtml_root/AJS_fx.js"></script>
308<script type="text/javascript" src="$yyhtml_root/greybox/gb_scripts.js"></script>
309~;
310        }
311    }
312
313    $yystyle =
314qq~<link rel="stylesheet" href="$yyhtml_root/Templates/Forum/$usestyle.css" type="text/css" />\n~;
315    $yystyle =~ s/$usestyle\///gxsm;
316    $yystyle .= $yyjsstyle;
317    $yystyle .= $yygreyboxstyle;
318    $yystyle .= $yyinlinestyle;
319
320    # Carsten's 'backtotop';
321    if ( !$yynavback ) { $yynavback .= q~ ~; }
322    $yynavback .=
323qq~$tabsep <span onclick="toTop(0)" class="cursor">$img_txt{'102'}</span> &nbsp; $tabsep~;
324
325    if ( !$usehead ) { $usehead = q~default~; }
326    $yytemplate = "$templatesdir/$usehead/$usehead.html";
327    fopen( TEMPLATE, $yytemplate ) or croak("$maintxt{'23'}: $yytemplate");
328    @whole_file = <TEMPLATE>;
329    $output = join q{}, @whole_file;
330    fclose(TEMPLATE);
331
332    if ( $iamadmin || $iamgmod ) {
333        if ($maintenance) {
334            if   ($do_scramble_id) { $user = cloak($username); }
335            else                   { $user = $username; }
336            $yyadmin_alert .=
337              qq~<br /><span class="highlight"><b>$load_txt{'616'}</b></span>~;
338            $yyadmin_alert =~ s/USER/$user/sm;
339        }
340        $rememberbackup ||= 0;
341        if ( $iamadmin && $rememberbackup > 0 ) {
342            if ( $lastbackup && $date > $rememberbackup + $lastbackup ) {
343                $yyadmin_alert .=
344                    qq~<br /><span class="highlight"><b>$load_txt{'617'} ~
345                  . timeformat($lastbackup)
346                  . q~</b></span>~;
347            }
348        }
349    }
350
351    # to top button for fixed menu
352    $yyfixtop  = qq~$img_txt{'to_top'}~;
353
354    $yyboardname = "$mbname";
355    $yyboardlink = qq~<a href="$scripturl">$mbname</a>~;
356
357    # static/dynamic clock
358    $yytime = timeformat( $date, 1 );
359    my $zone = q{};
360    if ( ($iamguest && $default_tz eq 'UTC') || (${ $uid . $username }{'user_tz'} eq 'UTC') || ( !$default_tz  &&  !${ $uid . $username }{'user_tz'} ) ) {
361        $zone = qq~ $maintxt{'UTC'}~;
362    }
363    my $toffs = 0;
364    if ( $enabletz ) {
365        $toffs = toffs($date);
366    }
367    if (
368        $mytimeselected != 7
369        && ( ( $iamguest && $dynamic_clock )
370            || ${ $uid . $username }{'dynamic_clock'} )
371      )
372    {
373        if ( $yytime =~ /(.*?)\d+:\d+((\w+)|:\d+)?/xsm ) {
374            ( $aa, $bb ) = ( $1, $3 );
375        }
376        $aa =~ s/<.+?>//gxsm;
377        if ( $mytimeselected == 6 ) { $bb = q{ }; }
378        $yytime =
379qq~&nbsp;<script  type="text/javascript">\nWriteClock('yabbclock','$aa','$bb');\n</script>~;
380        $yyjavascripta .=
381            qq~
382        var OurTime = ~
383          . sprintf( '%d', ( $date + $toffs ) )
384          . qq~000;\nvar YaBBTime = new Date();\nvar TimeDif = YaBBTime.getTime() - (YaBBTime.getTimezoneOffset() * 60000) - OurTime - 1000; // - 1000 compromise to transmission time~;
385    }
386    $yytime .= $zone;
387
388    $yyjavascripta .= qq~
389    var imagedir = "$imagesdir";
390    function toTop(scrpoint) {
391        window.scrollTo(0,scrpoint);
392    }~;
393
394    $yyjavascript .= q~
395    function txtInFields(thefield, defaulttxt) {
396        if (thefield.value == defaulttxt) thefield.value = "";
397        else { if (thefield.value === "") thefield.value = defaulttxt; }
398    }
399    function selectAllCode(thefield) {
400        var elem = document.getElementById('code' + thefield);
401        if (document.selection) {
402            document.selection.empty();
403            var txt = document.body.createTextRange();
404            txt.moveToElementText(elem);
405            txt.select();
406        }
407        else {
408            window.getSelection().removeAllRanges();
409            txt = document.createRange();
410            txt.setStartBefore(elem);
411            txt.setEndAfter(elem);
412            window.getSelection().addRange(txt);
413        }
414    }
415    ~;
416    require Sources::TabMenu;
417    mainMenu();
418
419
420    $yylangChooser = q{};
421    if ( ( $iamguest && !$guestLang ) && $enable_guestlanguage && $guestaccess )
422    {
423        if ( !$langopt ) { guestLangSel(); }
424        if ( $morelang > 1 ) {
425            $yylangChooser =
426qq~$guest_txt{'sellanguage'}: <form action="$scripturl?action=guestlang" method="post" name="sellanguage">
427            <select name="guestlang" onchange="submit();">
428            $langopt
429            </select>
430            </form>~;
431        }
432    }
433    elsif (( $iamguest && $guestLang )
434        && $enable_guestlanguage
435        && $guestaccess )
436    {
437        if ( !$langopt ) { guestLangSel(); }
438        if ( $morelang > 1 ) {
439            $yylangChooser =
440qq~$guest_txt{'changelanguage'}: <form action="$scripturl?action=guestlang" method="post" name="changelanguage">
441            <select name="guestlang" onchange="submit();">
442            $langopt
443            </select>
444            </form>~;
445        }
446    }
447
448    my $wmessage;
449    if ( $hour >= 12 && $hour < 18 ) {
450        $wmessage = $maintxt{'247a'};
451    }    # Afternoon
452    elsif ( $hour < 12 && $hour >= 0 ) {
453        $wmessage = $maintxt{'247m'};
454    }    # Morning
455    else { $wmessage = $maintxt{'247e'}; }    # Evening
456    if ($iamguest) {
457        $yyuname = qq~$maintxt{'248'} $maintxt{'28'}. $maintxt{'249'} <a href="~
458          . (
459            $loginform
460            ? "javascript:if(jumptologin>1)alert('$maintxt{'35'}');jumptologin++;window.scrollTo(0,10000);document.loginform.username.focus();"
461            : "$scripturl?action=login"
462          ) . qq~">$maintxt{'34'}</a>~;
463        if ($regtype) {
464            $yyuname .=
465qq~ $maintxt{'377'} <a href="$scripturl?action=register">$maintxt{'97'}</a>~;
466        }
467        $yyjavascript .= q~        jumptologin = 1;~;
468    }
469    else {
470        if ( ${ $uid . $username }{'bday'} ne q{} ) {
471            my ( $usermonth, $userday, $useryear ) =
472              split /\//xsm, ${ $uid . $username }{'bday'};
473            if ( $usermonth == $mon_num && $userday == $mday ) {
474                $wmessage = $maintxt{'247bday'};
475            }
476        }
477        $yyuname =
478          (      $PM_level == 0
479              || ( $PM_level == 2 && !$staff )
480              || ( $PM_level == 3 && !$iamadmin && !$iamgmod )
481              || ( $PM_level == 4 && !$iamadmin && !$iamgmod && !$iamfmod ) )
482          ? "$wmessage ${$uid.$username}{'realname'}"
483          : "$wmessage ${$uid.$username}{'realname'}, ";
484    }
485
486    # Add new notifications if allowed
487    if ( !$iamguest && $NewNotificationAlert ) {
488        if ( !$board_notify && !$thread_notify ) {
489            require Sources::Notify;
490            ( $board_notify, $thread_notify ) = NotificationAlert();
491        }
492        my ( $bo_num, $th_num );
493        foreach ( keys %{$board_notify} ) {   # boardname, boardnotifytype , new
494            if ( ${ $$board_notify{$_} }[2] ) { $bo_num++; }
495        }
496        foreach ( keys %{$thread_notify} )
497        { # mythread, msub, new, username_link, catname_link, boardname_link, lastpostdate
498            if ( ${ $$thread_notify{$_} }[2] ) { $th_num++; }
499        }
500        if ( $bo_num || $th_num ) {
501            my $noti_text = (
502                $bo_num
503                ? "$notify_txt{'201'} $notify_txt{'205'} ($bo_num)"
504                : q{}
505              )
506              . (
507                $th_num
508                ? ( $bo_num ? " $notify_txt{'202'} " : q{} )
509                  . "$notify_txt{'201'}  $notify_txt{'206'} ($th_num)"
510                : q{}
511              );
512            if ( ${ $uid . $username }{'onlinealert'} and $boardindex_template )
513            {
514                $yyadmin_alert =
515qq~<br />$notify_txt{'200'} <a href="$scripturl?action=shownotify">$noti_text</a>.$yyadmin_alert~;
516                $yymain .= qq~<script type="text/javascript">
517            window.setTimeout("Noti_Popup();", 1000);
518            function Noti_Popup() {
519                if (confirm('$notify_txt{'200'} $noti_text.\\n$notify_txt{'203'}'))
520                    window.location.href='$scripturl?action=shownotify';
521            }
522             </script>~;
523            }
524        }
525    }
526
527# check for copyright for special error - angle brackets no longer supported for yabb tags
528    if ( $output =~ m/{yabb\ copyright}/xsm ) {
529        $yycopyin = 1;
530    }
531
532    $yysearchbox = q{};
533    if ( !$iamguest || $guestaccess != 0 ) {
534        if ( $maxsearchdisplay > -1 && $qcksearchaccess eq 'granted' ) {
535            my $blurb = qq~$maintxt{'searchimg'} $qckage $maintxt{'searchimg2'}~;
536            if ( $qckage == 0 ) {
537                $blurb = qq~$maintxt{'searchimg3'}~;
538            }
539            $yysearchbox = qq~
540                    <form action="$scripturl?action=search2" method="post" accept-charset="$yymycharset">
541                        <input type="hidden" name="searchtype" value="$qcksearchtype" />
542                        <input type="hidden" name="userkind" value="any" />
543                        <input type="hidden" name="subfield" value="on" />
544                        <input type="hidden" name="msgfield" value="on" />
545                        <input type="hidden" name="age" value="$qckage" />
546                        <input type="hidden" name="oneperthread" value="1" />
547                        <input type="hidden" name="searchboards" value="!all" />
548                        <input type="text" name="search" size="16" id="search1" value="$img_txt{'182'}" style="font-size: 11px;" onfocus="txtInFields(this, '$img_txt{'182'}');" onblur="txtInFields(this, '$img_txt{'182'}')" />
549                        <input type="image" src="$imagesdir/search.png" alt="$blurb" title="$blurb" style="background-color: transparent; margin-right: 5px; vertical-align: middle;" />
550                    </form>
551~;
552        }
553    }
554    if ( $enable_news && ( -s "$vardir/news.txt" ) > 5 ) {
555        fopen( NEWS, "$vardir/news.txt" );
556        my @newsmessages = <NEWS>;
557        fclose(NEWS);
558        chomp @newsmessages;
559        my $startnews = int rand @newsmessages;
560        $yynewstitle = qq~<b>$maintxt{'102'}:</b>~;
561        $yynewstitle =~ s/'/\\'/gxsm;
562        $guest_media_disallowed = 0;
563        $newswrap               = 40;
564
565        if ($shownewsfader) {
566            $fadedelay = $maxsteps * $stepdelay;
567            $yynews .= qq~
568            <script type="text/javascript">
569                    var index = $startnews;
570                    var maxsteps = "$maxsteps";
571                    var stepdelay = "$stepdelay";
572                    var fadelinks = $fadelinks;
573                    var delay = "$fadedelay";
574                    function convProp(thecolor) {
575                        if(thecolor.charAt(0) == "#") {
576                            if(thecolor.length == 4) thecolor=thecolor.replace(/(\\#)([a-f A-F 0-10]{1,1})([a-f A-F 0-10]{1,1})([a-f A-F 0-10]{1,1})\/i, "\$1\$2\$2\$3\$3\$4\$4");
577                            var thiscolor = new Array(HexToR(thecolor), HexToG(thecolor), HexToB(thecolor));
578                            return thiscolor;
579                        }
580                        else if(thecolor.charAt(3) == "(") {
581                            thecolor=thecolor.replace(/rgb\\((\\d+?\\%*?)\\,(\\s*?)(\\d+?\\%*?)\\,(\\s*?)(\\d+?\\%*?)\\)/i, "\$1|\$3|\$5");
582                            thiscolor = thecolor.split("|");
583                            return thiscolor;
584                        }
585                        else {
586                            thecolor=thecolor.replace(/\\"/g, "");
587                            thecolor=thecolor.replace(/maroon/ig, "128|0|0");
588                            thecolor=thecolor.replace(/red/i, "255|0|0");
589                            thecolor=thecolor.replace(/orange/i, "255|165|0");
590                            thecolor=thecolor.replace(/olive/i, "128|128|0");
591                            thecolor=thecolor.replace(/yellow/i, "255|255|0");
592                            thecolor=thecolor.replace(/purple/i, "128|0|128");
593                            thecolor=thecolor.replace(/fuchsia/i, "255|0|255");
594                            thecolor=thecolor.replace(/white/i, "255|255|255");
595                            thecolor=thecolor.replace(/lime/i, "00|255|00");
596                            thecolor=thecolor.replace(/green/i, "0|128|0");
597                            thecolor=thecolor.replace(/navy/i, "0|0|128");
598                            thecolor=thecolor.replace(/blue/i, "0|0|255");
599                            thecolor=thecolor.replace(/aqua/i, "0|255|255");
600                            thecolor=thecolor.replace(/teal/i, "0|128|128");
601                            thecolor=thecolor.replace(/black/i, "0|0|0");
602                            thecolor=thecolor.replace(/silver/i, "192|192|192");
603                            thecolor=thecolor.replace(/gray/i, "128|128|128");
604                            thiscolor = thecolor.split("|");
605                            return thiscolor;
606                        }
607                    }
608                    if (ie4 || DOM2) var news = ('<span class="windowbg2" id="fadestylebak" style="display: none;"><span class="newsfader" id="fadestyle" style="display: none;"> </span></span>');
609                    var div = document.getElementById("newsdiv");
610                    div.innerHTML = news;
611                    if (document.getElementById('fadestyle').currentStyle) {
612                        tcolor = document.getElementById('fadestyle').currentStyle['color'];
613                        bcolor = document.getElementById('fadestyle').currentStyle['backgroundColor'];
614                        nfntsize = document.getElementById('fadestyle').currentStyle['fontSize'];
615                        fntstyle = document.getElementById('fadestyle').currentStyle['fontStyle'];
616                        fntweight = document.getElementById('fadestyle').currentStyle['fontWeight'];
617                        fntfamily = document.getElementById('fadestyle').currentStyle['fontFamily'];
618                        txtdecoration = document.getElementById('fadestyle').currentStyle['textDecoration'];
619                    }
620                    else if (window.getComputedStyle) {
621                        tcolor = window.getComputedStyle(document.getElementById('fadestyle'), null).getPropertyValue('color');
622                        bcolor = window.getComputedStyle(document.getElementById('fadestyle'), null).getPropertyValue('background-color');
623                        nfntsize = window.getComputedStyle(document.getElementById('fadestyle'), null).getPropertyValue('font-size');
624                        fntstyle = window.getComputedStyle(document.getElementById('fadestyle'), null).getPropertyValue('font-style');
625                        fntweight = window.getComputedStyle(document.getElementById('fadestyle'), null).getPropertyValue('font-weight');
626                        fntfamily = window.getComputedStyle(document.getElementById('fadestyle'), null).getPropertyValue('font-family');
627                        txtdecoration = window.getComputedStyle(document.getElementById('fadestyle'), null).getPropertyValue('text-decoration');
628                    }
629                    if (bcolor == "transparent" || bcolor == "rgba\\(0\\, 0\\, 0\\, 0\\)") {
630                        if (document.getElementById('fadestylebak').currentStyle) {
631                            tcolor = document.getElementById('fadestylebak').currentStyle['color'];
632                            bcolor = document.getElementById('fadestylebak').currentStyle['backgroundColor'];
633                        }
634                        else if (window.getComputedStyle) {
635                            tcolor = window.getComputedStyle(document.getElementById('fadestylebak'), null).getPropertyValue('color');
636                            bcolor = window.getComputedStyle(document.getElementById('fadestylebak'), null).getPropertyValue('background-color');
637                        }
638                    }
639                    txtdecoration = txtdecoration.replace(/\'/g, ""); //';
640                    var endcolor = convProp(tcolor);
641                    var startcolor = convProp(bcolor);~;
642            my $greybox = $img_greybox;
643            $img_greybox = 0;
644            foreach my $j ( 0 .. ( @newsmessages - 1 ) ) {
645                $message = $newsmessages[$j];
646                wrap();
647                if ($enable_ubbc) {
648                    enable_yabbc();
649                    $ns = q{};
650                    DoUBBC();
651                    $message =~
652                      s/ style="display:none"/ style="display:block"/gsm;
653                }
654                wrap2();
655                $message =~ s/"/\\"/gxsm;
656                ToChars($message);
657                $message =~ s/\'/&#39;/xsm;
658                $yynews .= qq~                  fcontent[$j] = '$message';\n~;
659            }
660            $img_greybox = $greybox;
661            $yynews .= q~
662                        document.getElementById("newsdiv").style.fontSize=nfntsize;
663                        document.getElementById("newsdiv").style.fontWeight=fntweight;
664                        document.getElementById("newsdiv").style.fontStyle=fntstyle;
665                        document.getElementById("newsdiv").style.fontFamily=fntfamily;
666                        document.getElementById("newsdiv").style.textDecoration=txtdecoration;
667
668                    if (window.addEventListener)
669                        window.addEventListener("load", changecontent, false);
670                    else if (window.attachEvent)
671                        window.attachEvent("onload", changecontent);
672                    else if (document.getElementById)
673                        window.onload = changecontent;
674            </script>
675        ~;
676        }
677        else {
678            $message = $newsmessages[$startnews];
679            wrap();
680            if ($enable_ubbc) {
681                enable_yabbc();
682                DoUBBC();
683                $message =~ s/ style="display:none"/ style="display:block"/gsm;
684            }
685            wrap2();
686            ToChars($message);
687            $message =~ s/\'/&#39;/xsm;
688            $yynews = qq~
689            <script type="text/javascript">
690                if (ie4 || DOM2) var news = '$message';
691                var div = document.getElementById("newsdiv");
692                div.innerHTML = news;
693            </script>~;
694        }
695        $newswrap = 0;
696    }
697    else {
698        $yynews = '&nbsp;';
699    }
700
701    if ( $debug == 1 || ( $debug == 2 && $iamadmin ) || $debug == 3 ) {
702        require Sources::Debug;
703        LoadLanguage('Debug');
704        Debug();
705    }
706
707    $yyurl = $scripturl;
708    my $copyright = $output =~ m/{yabb\ copyright}/xsm ? 1 : 0;
709
710    # new and old tag template style decoding - the (<|{) and (}|>) must remain for it to work.
711    while ( $output =~ s/(<|{)yabb\s+(\w+)(}|>)/${"yy$2"}/gxsm ) { }
712
713    # check if image exists, otherwise use the default template image
714    if ( $imagesdir ne $defaultimagesdir ) {
715        my %img_locs;
716
717        $output =~
718s/(src|value|url)(=|\()("|'| )$imagesdir\/([^'" ]+)./ "$1$2$3" . ImgLoc($4) . $3 /eisgm;
719    }
720
721    # add formsession to each <form ..>-tag
722    $output =~
723s/<\/form>/ <input type="hidden" name="formsession" value="$formsession" \/>\n                    <\/form>/gsm;
724
725    image_resize();
726
727    # Start workaround to substitute all ';' by '&' in all URLs
728    # This workaround solves problems with servers that use mod_security
729    # in a very strict way. (error 406)
730    # Take the comments out of the following two lines if you had this problem.
731    # $output =~ s/($scripturl\?)([^'"]+)/ $1 . URL_modify($2) /eg;
732    # sub URL_modify { my $x = shift; $x =~ s/;/&amp;/g; $x; }
733    # End of workaround
734
735    if ( !$copyright ) {
736        $output =
737q~<h1 class="center"><b>Sorry, the copyright tag &#123;yabb copyright&#125; must be in the template.<br />Please notify this forum&#39;s administrator that this site is using an ILLEGAL copy of YaBB!</b></h1>~;
738    }
739
740    print_HTML_output_and_finish();
741    return;
742}
743
744sub PMlev {
745    my $pm_lev = 0;
746    if (   $PM_level == 1
747        || ( $PM_level == 2 && $staff )
748        || ( $PM_level == 3 && ( $iamadmin || $iamgmod ) )
749        || ( $PM_level == 4 && ( $iamadmin || $iamgmod || $iamfmod ) ) )
750    {
751        $pm_lev = 1;
752    }
753    return $pm_lev;
754}
755
756sub image_resize {
757    my ( $resize_js, $resize_num );
758    my $perl_do_it = 0;
759
760# Hardcoded! Set to 1 for Perl to do the fix...size work here. Set to 0 for the javascript within the browser do this work.
761
762    *check_image_resize = sub {
763        my @x  = @_;
764        my $px = 'px';
765        if ( $fix_avatar_img_size && $perl_do_it == 1 && $x[1] eq 'avatar' ) {
766            if ( $max_avatar_width && $x[2] !~ / width=./sm ) {
767                $x[2] =~ s/( style=.)/$1width:$max_avatar_width$px;/sm;
768            }
769            if ( $max_avatar_height && $x[2] !~ / height=./sm ) {
770                $x[2] =~ s/( style=.)/$1height:$max_avatar_height$px;/sm;
771            }
772            $x[2] =~ s/display:none/display:inline/sm;
773        }
774        elsif ($fix_avatarml_img_size
775            && $perl_do_it == 1
776            && $x[1] eq 'avatarml' )
777        {
778            if ( $max_avatarml_width && $x[2] !~ / width=./sm ) {
779                $x[2] =~ s/( style=.)/$1width:$max_avatarml_width\px;/sm;
780            }
781            if ( $max_avatarml_height && $x[2] !~ / height=./sm ) {
782                $x[2] =~ s/( style=.)/$1height:$max_avatarml_height\px;/sm;
783            }
784            $x[2] =~ s/display:none/display:inline/sm;
785        }
786        elsif ( $fix_post_img_size && $perl_do_it == 1 && $x[1] eq 'post' ) {
787            if ( $max_post_width && $x[2] !~ / width=./sm ) {
788                $x[2] =~ s/( style=.)/$1width:$max_post_width$px;/sm;
789            }
790            if ( $max_post_height && $x[2] !~ / height=./sm ) {
791                $x[2] =~ s/( style=.)/$1height:$max_post_height$px;/sm;
792            }
793            $x[2] =~ s/display:none/display:inline/xsm;
794        }
795        elsif ( $fix_attach_img_size && $perl_do_it == 1 && $x[1] eq 'attach' )
796        {
797            if ( $max_attach_width && $x[2] !~ / width=./sm ) {
798                $x[2] =~ s/( style=.)/$1width:$max_attach_width$px;/sm;
799            }
800            if ( $max_attach_height && $x[2] !~ / height=./sm ) {
801                $x[2] =~ s/( style=.)/$1height:$max_attach_height$px;/sm;
802            }
803            $x[2] =~ s/display:none/display:inline/xsm;
804        }
805        elsif ( $fix_signat_img_size && $perl_do_it == 1 && $x[1] eq 'signat' )
806        {
807            if ( $max_signat_width && $x[2] !~ / width=./sm ) {
808                $x[2] =~ s/( style=.)/$1width:$max_signat_width$px;/sm;
809            }
810            if ( $max_signat_height && $x[2] !~ / height=./sm ) {
811                $x[2] =~ s/( style=.)/$1height:$max_signat_height$px;/sm;
812            }
813            $x[2] =~ s/display:none/display:inline/xsm;
814        }
815        elsif ( $fix_brd_img_size  && $perl_do_it == 1 && $x[1] eq 'brd' )
816        {
817            if ( $max_brd_img_width && $x[2] !~ / width=./sm ) {
818                $x[2] =~ s/( style=.)/$1width:$max_brd_img_width$px;/sm;
819            }
820            if ( $max_brd_img_height && $x[2] !~ / height=./sm ) {
821                $x[2] =~ s/( style=.)/$1height:$max_brd_img_height$px;/sm;
822            }
823            $x[2] =~ s/display:none/display:inline/sm;
824        }
825        else {
826            $resize_num++;
827            $x[0] .= "_$resize_num";
828            $resize_js .= "'$x[0]',";
829        }
830        return qq~"$x[0]"$x[2]~;
831    };
832    $output =~
833s/"((avatar|avatarml|post|attach|signat|brd)_img_resize)"([^>]*>)/ check_image_resize($1,$2,$3) /gesm;
834
835    if ($resize_num) {
836        $avatar_img_w    = isempty( $max_avatar_width, 65 );
837        $avatar_img_h    = isempty( $max_avatar_height, 65 );
838        $avatarml_img_w  = isempty( $max_avatarml_width, 65 );
839        $avatarml_img_h  = isempty( $max_avatarml_height, 65 );
840        $post_img_w      = isempty( $max_post_img_width, 0 );
841        $post_img_h      = isempty( $max_post_img_height, 0 );
842        $attach_img_w    = isempty( $max_attach_img_width, 0 );
843        $attach_img_h    = isempty( $max_attach_img_height, 0 );
844        $signat_img_w    = isempty( $max_signat_img_width, 0 );
845        $signat_img_h    = isempty( $max_signat_img_height, 0 );
846        $brd_img_w       = isempty( $max_brd_img_width, 50 );
847        $brd_img_h       = isempty( $max_brd_img_height, 50 );
848        $fix_brd_img_size = isempty( $fix_brd_img_size, 0 );
849
850        $resize_js =~ s/,$//xsm;
851        $resize_js = qq~<script type="text/javascript">
852    // resize image start
853    var resize_time = 2;
854    var img_resize_names = new Array ($resize_js);
855
856    var avatar_img_w    = $avatar_img_w;
857    var avatar_img_h    = $avatar_img_h;
858    var fix_avatar_size = $fix_avatar_img_size;
859    var avatarml_img_w    = $avatarml_img_w;
860    var avatarml_img_h    = $avatarml_img_h;
861    var fix_avatarml_size = $fix_avatarml_img_size;
862    var post_img_w      = $post_img_w;
863    var post_img_h      = $post_img_h;
864    var fix_post_size   = $fix_post_img_size;
865    var attach_img_w    = $attach_img_w;
866    var attach_img_h    = $attach_img_h;
867    var fix_attach_size = $fix_attach_img_size;
868    var signat_img_w    = $signat_img_w;
869    var signat_img_h    = $signat_img_h;
870    var fix_signat_size = $fix_signat_img_size;
871    var brd_img_w       = $brd_img_w;
872    var brd_img_h       = $brd_img_h;
873    var fix_brd_size    = $fix_brd_img_size;
874
875    noimgdir   = '$imagesdir';
876    noimgtitle = '$maintxt{'171'}';
877
878    resize_images();
879    // resize image end
880</script>~;
881
882        $output =~ s/(<\/body>)/$resize_js\n$1/sm;
883    }
884    return;
885}
886
887sub get_caller {
888
889    # Gets filename and line where fatal_error/debug was called.
890    # Need to go further back to get correct subroutine name,
891    # otherwise will print fatal_error/debug as current subroutine!
892    my ( undef, $filename, $line ) = caller 1;
893    my ( undef, undef, undef, $subroutine ) = caller 2;
894    return ( $filename, $line, $subroutine );
895}
896
897sub fatal_error {
898    my @x       = @_;
899    my $verbose = $!;
900
901    LoadLanguage('Error');
902    get_template('Other');
903
904    my $errormessage = $x[0] ? ( $error_txt{$x[0]} . ( $x[1] ? " $x[1]" : q{} ) ) : isempty( $x[1], q{} );
905
906    my ( $filename, $line, $subroutine ) = get_caller();
907    if (   ( $debug == 1 || ( $debug == 2 && $iamadmin ) )
908        && ( $filename || $line || $subroutine ) )
909    {
910        LoadLanguage('Debug');
911        $errormessage .=
912qq~<br />$maintxt{'error_location'}: $filename<br />$maintxt{'error_line'}: $line<br />$maintxt{'error_subroutine'}: $subroutine~;
913    }
914
915    if ( $x[2] ) {
916        $errormessage .= "<br />$maintxt{'error_verbose'}: $verbose";
917    }
918
919    if ($elenable) { fatal_error_logging($errormessage); }
920
921    # for ajax calls that return errors, so no page is generated
922    if ($no_error_page) {
923        print "Content-type: text/plain\n\nerror$errormessage"
924          or croak "$croak{'print'} error";
925        CORE::exit;    # This is here only to avoid server error log entries!
926    }
927
928    $yymain .= $my_show_error;
929    $yymain =~ s/{yabb errormessage}/$errormessage/sm;
930    $yytitle = "$maintxt{'error_description'}";
931
932    if ( $adminscreen && $action ne 'admincheck2' ) {
933        AdminTemplate();
934    }
935    else {
936        if ( $x[0] =~ /no_access|members_only|no_perm/xsm ) {
937            $headerstatus = '403 Forbidden';
938        }
939        elsif ( $x[0] =~ /cannot_open|no.+_found/xsm ) {
940            $headerstatus = '404 Not Found';
941        }
942        template();
943    }
944    return;
945}
946
947sub fatal_error_logging {
948    my ($tmperror) = @_;
949
950# This flaw was brought to our attention by S M <savy91@msn.com> Italy
951# Thanks! We couldn't make YaBB successful without the help from the bug testers.
952    ToHTML($action);
953    ToHTML( $INFO{'num'} );
954    ToHTML($currentboard);
955
956    $tmperror =~ s/\n//igsm;
957    fopen( ERRORLOG, "<$vardir/errorlog.txt" );
958    my @errorlog = <ERRORLOG>;
959    fclose( ERRORLOG );
960    chomp @errorlog;
961    $errorcount = @errorlog;
962
963    if ($elrotate) {
964        while ( $errorcount >= $elmax ) {
965            shift @errorlog;
966            $errorcount = @errorlog;
967        }
968    }
969
970    foreach my $formdata ( keys %FORM ) {
971        chomp $FORM{$formdata};
972        $FORM{$formdata} =~ s/\n//igsm;
973    }
974
975    if ($iamguest) {
976        push @errorlog,
977          int(time)
978          . "|$date|$user_ip|$tmperror|$action|$INFO{'num'}|$currentboard|$FORM{'username'}|$FORM{'passwrd'}\n";
979    }
980    else {
981        push @errorlog,
982          int(time)
983          . "|$date|$user_ip|$tmperror|$action|$INFO{'num'}|$currentboard|$username|$FORM{'passwrd'}\n";
984    }
985    fopen( ERRORLOG, ">$vardir/errorlog.txt" );
986    foreach (@errorlog) {
987        chomp;
988        if ( $_ ne q{} ) {
989            print {ERRORLOG} $_ . "\n" or croak "$croak{'print'} ERRORLOG";
990        }
991    }
992    fclose(ERRORLOG);
993    return;
994}
995
996sub FindPermalink {
997    my ($old_env) = @_;
998    $old_env        = substr $old_env, 1, length $old_env;
999    $permtopicfound = 0;
1000    $permboardfound = 0;
1001    $is_perm        = 1;
1002    ## strip off symlink for redirectlike e.g. /articles/ ##
1003    $old_env =~ s/$symlink//gxsm;
1004    ## get date/time/board/topic from permalink
1005
1006    ( $permyear, $permmonth, $permday, $permboard, $permnum ) =
1007      split /\//xsm, $old_env;
1008    if ( -e "$boardsdir/$permboard.txt" ) {
1009        $permboardfound = 1;
1010        if ( $permnum ne q{} && -e "$datadir/$permnum.txt" ) {
1011            $new_env        = qq~num=$permnum~;
1012            $permtopicfound = 1;
1013        }
1014        else { $new_env = qq~board=$permboard~; }
1015    }
1016    return $new_env;
1017}
1018
1019sub permtimer {
1020    my ($thetime) = @_;
1021    my $mynewtime =  $thetime;
1022
1023    my ( undef, $pmin, $phour, $pmday, $pmon, $pyear, undef, undef, undef ) =
1024      gmtime( $mynewtime );
1025    my $pmon_num = $pmon + 1;
1026    $phour    = sprintf '%02d', $phour;
1027    $pmin     = sprintf '%02d', $pmin;
1028    $pyear    = 1900 + $pyear;
1029    $pmon_num = sprintf '%02d', $pmon_num;
1030    $pmday    = sprintf '%02d', $pmday;
1031    $pyear    = sprintf '%04d', $pyear;
1032    return "$pyear/$pmon_num/$pmday";
1033}
1034
1035sub readform {
1036    my ( @pairs, $pair, $name, $value );
1037    if ( substr( $ENV{QUERY_STRING}, 0, 1 ) eq q{/} && $accept_permalink ) {
1038        $ENV{QUERY_STRING} = FindPermalink( $ENV{QUERY_STRING} );
1039    }
1040    if ( $ENV{QUERY_STRING} =~ m/action\=dereferer/xsm ) {
1041        $INFO{'action'} = 'dereferer';
1042        $urlstart = index $ENV{QUERY_STRING}, 'url=';
1043        $INFO{'url'} = substr
1044          $ENV{QUERY_STRING},
1045          $urlstart + 4,
1046          length( $ENV{QUERY_STRING} ) - $urlstart + 3;
1047        $INFO{'url'} =~ s/\;anch\=/#/gxsm;
1048        $testenv = q{};
1049    }
1050    else {
1051        $testenv = $ENV{QUERY_STRING};
1052        $testenv =~ s/\&/\;/gxsm;
1053        if ( $testenv && $debug ) {
1054            LoadLanguage('Debug');
1055            $getpairs =
1056qq~<br /><span class="underline">$debug_txt{'getpairs'}:</span><br />~;
1057        }
1058    }
1059
1060# URL encoding for web.de http://www.blooberry.com/indexdot/html/topics/urlencoding.htm
1061    $testenv =~ s/\%3B/;/igxsm;
1062
1063    # search must be case insensitive for some servers!
1064    $testenv =~ s/\%26/&/gxsm;
1065
1066    split_string( \$testenv, \%INFO, 1 );
1067    if ( $ENV{'SERVER_SOFTWARE'} =~ /IIS/sm ) {
1068        ( $dummy,  $IISver )  = split /\//xsm, $ENV{'SERVER_SOFTWARE'};
1069        ( $IISver, $IISverM ) = split /./xsm,  $IISver;
1070        if ( int($IISver) < 6 && int($IISverM) < 1 ) {
1071            eval { use CGI qw(:standard) };
1072        }
1073    }
1074    if ( $ENV{REQUEST_METHOD} eq 'POST' ) {
1075        if ($debug) {
1076            LoadLanguage('Debug');
1077            $getpairs .=
1078qq~<br /><span class="underline">$debug_txt{'postpairs'}:</span><br />~;
1079        }
1080        if ( $ENV{CONTENT_TYPE} =~ /multipart\/form-data/xsm ) {
1081            require CGI;
1082
1083           # A possible attack is for the remote user to force CGI.pm to accept
1084           # a huge file upload. CGI.pm will accept the upload and store it in
1085           # a temporary directory even if your script doesn't expect to receive
1086           # an uploaded file. CGI.pm will delete the file automatically when it
1087           # terminates, but in the meantime the remote user may have filled up
1088           # the server's disk space, causing problems for other programs.
1089           # The best way to avoid denial of service attacks is to limit the
1090           # amount of memory, CPU time and disk space that CGI scripts can use.
1091           # If $CGI::POST_MAX is set to a non-negative integer, this variable
1092           # puts a ceiling on the size of POSTings, in bytes. If CGI.pm detects
1093           # a POST that is greater than the ceiling, it will immediately exit
1094           # with an error message like this:
1095           # "413 Request entity too large"
1096           # This value will affect both ordinary POSTs and multipart POSTs,
1097           # meaning that it limits the maximum size of file uploads as well.
1098            $allowattach   ||= 0;
1099            $allowAttachIM ||= 0;
1100            $limit         ||= 0;
1101            $pmFileLimit   ||= 0;
1102            if (   $allowattach > 0
1103                && $ENV{'QUERY_STRING'} =~ /action=(post|modify)2\b/xsm )
1104            {
1105                $CGI::POST_MAX = int( 1024 * $limit * $allowattach );
1106                if ($CGI::POST_MAX) { $CGI::POST_MAX += 1048576; }    # *
1107            }
1108            elsif ( $allowAttachIM > 0
1109                && $ENV{'QUERY_STRING'} =~ /action=(imsend|imsend2)\b/xsm )
1110            {
1111                $CGI::POST_MAX = int( 1024 * $pmFileLimit * $allowAttachIM );
1112                if ($CGI::POST_MAX) { $CGI::POST_MAX += 1048576; }    # *
1113            }
1114            elsif ( $upload_useravatar
1115                && $ENV{'QUERY_STRING'} =~ /action=profileOptions2\b/xsm )
1116            {
1117                $avatar_limit ||= 0;
1118                $CGI::POST_MAX = int( 1024 * $avatar_limit );
1119                if ($CGI::POST_MAX) { $CGI::POST_MAX += 1048576; }    # *
1120            }
1121            else {
1122
1123                # If NO uploads are allowed YaBB sets this default limit
1124                # to 1 MB. Change this values if you get error messages.
1125                $CGI::POST_MAX = 1048576;
1126            }
1127
1128        # * adds volume, if a upload limit is set, to not get error if the other
1129        # uploaded data is larger. Change this values if you get error messages.
1130            $CGI_query = CGI->new;
1131
1132            # $CGI_query must be a global variable
1133            my (@value);
1134            foreach my $name ( $CGI_query->param() ) {
1135                if ( $name =~ /^file(\d+|_avatar)$/xsm ) { next; }
1136
1137        # files are directly called in Profile.pm, Post.pm and ModifyMessages.pl
1138                @value = $CGI_query->param($name);
1139                if ($debug) {
1140                    LoadLanguage('Debug');
1141                    $getpairs .=
1142qq~[$debug_txt{'name'}-&gt;]$name=@value\[&lt;-$debug_txt{'value'}]<br />~;
1143                }
1144                $FORM{$name} = join q{, }, @value;  # multiple values are joined
1145            }
1146        }
1147        else {
1148            read STDIN, my $input, $ENV{CONTENT_LENGTH};
1149            split_string( \$input, \%FORM );
1150        }
1151    }
1152    $action = $INFO{'action'} || $FORM{'action'};
1153
1154    # Formsession checking moved to YaBB.pl to fix a bug.
1155    if (   $INFO{'username'}
1156        && $do_scramble_id
1157        && $action ne 'view_regentry'
1158        && $action ne 'del_regentry'
1159        && $action ne 'activate' )
1160    {
1161        $INFO{'username'} = decloak( $INFO{'username'} );
1162    }
1163    if (   $FORM{'username'}
1164        && $do_scramble_id
1165        && $action ne 'login2'
1166        && $action ne 'reminder2'
1167        && $action ne 'register2'
1168        && $action ne 'profile2'
1169        && $action ne 'admin_descision' )
1170    {
1171        $FORM{'username'} = decloak( $FORM{'username'} );
1172    }
1173    if ( $INFO{'to'} && $do_scramble_id ) {
1174        $INFO{'to'} = decloak( $INFO{'to'} );
1175    }
1176    if ( $FORM{'to'} && $do_scramble_id ) {
1177        $FORM{'to'} = decloak( $FORM{'to'} );
1178    }
1179    return;
1180}
1181
1182sub split_string {
1183    my ( $string, $hash, $altdelim ) = @_;
1184
1185    if ( $altdelim && ${$string} =~ m{;}sm ) {
1186        @pairs = split /;/xsm, ${$string};
1187    }
1188    else { @pairs = split /&/xsm, ${$string}; }
1189    foreach my $pair (@pairs) {
1190        my ( $name, $value ) = split /=/xsm, $pair;
1191        $name  =~ tr/+/ /;
1192        $name  =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack('C', hex($1))/egsm;
1193        $value =~ tr/+/ /;
1194        $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack('C', hex($1))/egsm;
1195        if ($debug) {
1196            LoadLanguage('Debug');
1197            $getpairs .=
1198qq~[$debug_txt{'name'}-&gt;]$name=$value\[&lt;-$debug_txt{'value'}]<br />~;
1199        }
1200        if ( exists( $hash->{$name} ) ) {
1201            $hash->{$name} .= ", $value";
1202        }
1203        else {
1204            $hash->{$name} = $value;
1205        }
1206    }
1207    return;
1208}
1209
1210sub getlog {
1211    return
1212      if %yyuserlog
1213          || $iamguest
1214          || !$max_log_days_old
1215          || !-e "$memberdir/$username.log";
1216
1217    %yyuserlog = ();
1218    fopen( GETLOG, "$memberdir/$username.log" );
1219    my @logentries = <GETLOG>;
1220    fclose(GETLOG);
1221    chomp @logentries;
1222
1223    foreach (@logentries) {
1224        my ( $name, $thistime ) = split /\|/xsm, $_;
1225        if ( $name && $thistime ) { $yyuserlog{$name} = $thistime; }
1226    }
1227    return;
1228}
1229
1230sub dumplog {
1231    my @dum = @_;
1232    return if $iamguest || !$max_log_days_old;
1233
1234    if ( $dum[0] ) {
1235        getlog();
1236        $yyuserlog{ $dum[0] } = $dum[1] || $date;
1237    }
1238    if (%yyuserlog) {
1239        my $name;
1240        $date2 = $date;
1241        fopen( DUMPLOG, ">$memberdir/$username.log" );
1242        while ( ( $name, $date1 ) = each %yyuserlog ) {
1243            $result = calcdifference( $date1, $date2 );    # output => $result
1244            if ( $result <= $max_log_days_old ) {
1245                print {DUMPLOG} qq~$name|$date1\n~
1246                  or croak "$croak{'print'} DUMPLOG";
1247            }
1248        }
1249        fclose(DUMPLOG);
1250    }
1251    return;
1252}
1253
1254## standard jump to menu
1255sub jumpto {
1256    ## jump links to messages/favourites/notifications.
1257    my $action = 'action=jump';
1258    my $onchange =
1259qq~ onchange="if(this.options[this.selectedIndex].value) window.location.href='$scripturl?' + this.options[this.selectedIndex].value;"~;
1260    if ( $templatejump == 1 ) {
1261        $action   = 'action=';
1262        $onchange = q{};
1263    }
1264    $selecthtml = qq~
1265            <form method="post" action="$scripturl?$action" style="display: inline;">
1266                <select name="values"$onchange>
1267                    <option value="" class="forumjump">$jumpto_txt{'to'}</option>
1268                    <option value="gohome">$img_txt{'103'}</option>~;
1269
1270    ## as guests do not have these, why show them?
1271    if ( !$iamguest ) {
1272        $pm_lev = PMlev();
1273        if ( $pm_lev == 1 ) {
1274            $selecthtml .= qq~
1275                    <option value="action=im" class="forumjumpcatm">$jumpto_txt{'mess'}</option>~;
1276        }
1277        $selecthtml .= qq~
1278                    <option value="action=shownotify" class="forumjumpcatmf">$jumpto_txt{'note'}</option>
1279                    <option value="action=favorites" class="forumjumpcatm">$jumpto_txt{'fav'}</option>~;
1280    }
1281
1282    # drop in recent topics/posts lists. guests can see if browsing permitted
1283    $selecthtml .= qq~
1284                    <option value="action=recent;display=10">$recent_txt{'recentposts'}</option>
1285                    <option value="action=recenttopics;display=10">$recent_txt{'recenttopic'}</option>\n~;
1286
1287    get_forum_master();
1288    foreach my $catid (@categoryorder) {
1289        my @bdlist = split /,/xsm, $cat{$catid};
1290        my ( $catname, $catperms ) = split /\|/xsm, $catinfo{"$catid"};
1291
1292        my $cataccess = CatAccess($catperms);
1293        if ( !$cataccess ) { next; }
1294        ToChars($catname);
1295
1296        $selecthtml .=
1297          $INFO{'catselect'} eq $catid
1298          ? qq~    <option selected="selected" value="catselect=$catid" class="forumjumpcat">&raquo;&raquo; $catname</option>\n~
1299          : qq~    <option value="catselect=$catid" class="forumjumpcat">$catname</option>\n~;
1300
1301        my $indent = -2;
1302
1303        *jump_subboards = sub {
1304            my @x = @_;
1305            $indent += 2;
1306            foreach my $board (@x) {
1307                my $dash;
1308                if ( $indent > 0 ) { $dash = q{-}; }
1309
1310                my ( $boardname, $boardperms, $boardview ) =
1311                  split /\|/xsm, $board{"$board"};
1312                ToChars($boardname);
1313                my $access = AccessCheck( $board, q{}, $boardperms );
1314                if ( !$iamadmin && $access ne 'granted' && $boardview != 1 ) {
1315                    next;
1316                }
1317                if ( ${ $uid . $board }{'brdpasswr'} ) {
1318                    my $bdmods = ${ $uid . $board }{'mods'};
1319                    $bdmods =~ s/\, /\,/gsm;
1320                    $bdmods =~ s/\ /\,/gsm;
1321                    my %moderators = ();
1322                    my $pswiammod  = 0;
1323                    foreach my $curuser ( split /\,/xsm, $bdmods ) {
1324                        if ( $username eq $curuser ) { $pswiammod = 1; }
1325                    }
1326                    my $bdmodgroups = ${ $uid . $board }{'modgroups'};
1327                    $bdmodgroups =~ s/\, /\,/gsm;
1328                    my %moderatorgroups = ();
1329
1330                    foreach my $curgroup ( split /\,/xsm, $bdmodgroups ) {
1331                        if ( ${ $uid . $username }{'position'} eq $curgroup ) {
1332                            $pswiammod = 1;
1333                        }
1334                        foreach my $memberaddgroups ( split /\, /sm,
1335                            ${ $uid . $username }{'addgroups'} )
1336                        {
1337                            chomp $memberaddgroups;
1338                            if ( $memberaddgroups eq $curgroup ) {
1339                                $pswiammod = 1;
1340                                last;
1341                            }
1342                        }
1343                    }
1344                    my $cookiename = "$cookiepassword$board$username";
1345                    my $crypass    = ${ $uid . $board }{'brdpassw'};
1346
1347                    if (   !$iamadmin
1348                        && !$iamgmod
1349                        && !$pswiammod
1350                        && $yyCookies{$cookiename} ne $crypass )
1351                    {
1352                        next;
1353                    }
1354                }
1355                if (   $board eq $annboard
1356                    && !$iamadmin
1357                    && !$iamgmod
1358                    && !$iamfmod )
1359                {
1360                    next;
1361                }
1362
1363                if ( $board eq $currentboard ) {
1364                    $selecthtml .=
1365                      $INFO{'num'}
1366                      ? qq~    <option value="board=$board" class="forumcurrentboard">&nbsp;~
1367                      . ( '&nbsp;' x $indent )
1368                      . ( $dash x ( $indent / 2 ) )
1369                      . qq~ $boardname &#171;&#171;</option>\n~
1370                      : qq~    <option selected="selected" value="board=$board" class="forumcurrentboard">&raquo;&raquo; $boardname</option>\n~;
1371                }
1372                elsif ( !${ $uid . $board }{'canpost'} && $subboard{$board} ) {
1373                    $selecthtml .=
1374                        qq~    <option value="boardselect=$board">&nbsp;~
1375                      . ( '&nbsp;' x $indent )
1376                      . ( $dash x ( $indent / 2 ) )
1377                      . qq~ $boardname</option>\n~;
1378                }
1379                else {
1380                    $selecthtml .=
1381                        qq~    <option value="board=$board">&nbsp;~
1382                      . ( '&nbsp;' x $indent )
1383                      . ( $dash x ( $indent / 2 ) )
1384                      . qq~ $boardname</option>\n~;
1385                }
1386
1387                if ( $subboard{$board} ) {
1388                    jump_subboards( split /\|/xsm, $subboard{$board} );
1389                }
1390            }
1391            $indent -= 2;
1392        };
1393        jump_subboards(@bdlist);
1394    }
1395    $selecthtml .= qq~</select>
1396            </form>~;
1397    return $selecthtml;
1398}
1399
1400sub dojump {
1401    $yySetLocation = $scripturl . $FORM{'values'};
1402    redirectexit();
1403    return;
1404}
1405
1406sub spam_protection {
1407    return if !$timeout || $iamadmin;
1408    my ( $flood_ip, $flood_time, $flood, @floodcontrol );
1409
1410    if ( -e "$vardir/flood.txt" ) {
1411        fopen( FLOOD, "$vardir/flood.txt" );
1412        push @floodcontrol, "$user_ip|$date\n";
1413        while (<FLOOD>) {
1414            chomp $_;
1415            ( $flood_ip, $flood_time ) = split /\|/xsm, $_;
1416            if ( $user_ip eq $flood_ip && $date - $flood_time <= $timeout ) {
1417                $flood = 1;
1418            }
1419            elsif ( $date - $flood_time < $timeout ) {
1420                push @floodcontrol, "$_\n";
1421            }
1422        }
1423        fclose(FLOOD);
1424    }
1425    if ( $flood && !$iamadmin ) {
1426        if ( $action eq 'post2' ) {
1427            Preview("$maintxt{'409'} $timeout $maintxt{'410'}");
1428        }
1429        else {
1430            fatal_error( 'post_flooding', "$timeout $maintxt{'410'}" );
1431        }
1432    }
1433    fopen( FLOOD, ">$vardir/flood.txt", 1 );
1434    print {FLOOD} @floodcontrol or croak "$croak{'print'} FLOOD";
1435    fclose(FLOOD);
1436    return;
1437}
1438
1439sub SpamQuestion {
1440    srand;
1441    fopen( SPAMQUESTIONS, "<$langdir/$language/spam.questions" )
1442      or fatal_error( 'cannot_open', "$langdir/$language/spam.questions", 1 );
1443    while (<SPAMQUESTIONS>) {
1444        rand($INPUT_LINE_NUMBER) < 1 && ( $spam_question_rand = $_ );
1445    }
1446    fclose(SPAMQUESTIONS);
1447    chomp $spam_question_rand;
1448    ( $spam_question_id, $spam_question, undef, $spam_questions_case, $spam_image ) =
1449      split /\|/xsm, $spam_question_rand;
1450    $spam_image = $spam_image ? qq~<div style="margin-top: .5em;"><img src="$defaultimagesdir/Spam_Img/$spam_image" alt="" /></div>~ : q{};
1451    return;
1452}
1453
1454sub SpamQuestionCheck {
1455    my ( $verification_question, $verification_question_id ) = @_;
1456    fopen( SPAMQUESTIONS, "<$langdir/$language/spam.questions" )
1457      or fatal_error( 'cannot_open', "$langdir/$language/spam.questions", 1 );
1458    @spam_questions = <SPAMQUESTIONS>;
1459    fclose(SPAMQUESTIONS);
1460    foreach my $verification_question (@spam_questions) {
1461        chomp $verification_question;
1462        if ( $verification_question =~ /$verification_question_id/xsm ) {
1463            ( undef, undef, $verification_answer, $spam_questions_case, undef ) =
1464              split /\|/xsm, $verification_question;
1465        }
1466    }
1467    $verification_question =~ s/\A\s+//xsm;
1468    $verification_question =~ s/\s+\Z//xsm;
1469    if ( !$spam_questions_case ) {
1470        $verification_answer   = lc $verification_answer;
1471        $verification_question = lc $verification_question;
1472    }
1473    if ( $verification_question eq q{} ) {
1474        fatal_error('no_verification_question');
1475    }
1476    @verificationanswer = split /,/xsm, $verification_answer;
1477    foreach (@verificationanswer) {
1478        $_ =~ s/\A\s+//xsm;
1479        $_ =~ s/\s+\Z//xsm;
1480    }
1481    if ( !grep { $verification_question eq $_ } @verificationanswer ) {
1482        fatal_error('wrong_verification_question');
1483    }
1484    return;
1485}
1486
1487sub CountChars {
1488    $convertstr =~ s/&#32;/ /gsm;    # why? where? (deti)
1489
1490    $cliped = 0;
1491    my ( $string, $curstring, $stinglength, $teststring );
1492    foreach my $string ( split /\s+/xsm, $convertstr ) {
1493      CHECKAGAIN:
1494
1495        # jump over HTML-tags
1496        if ( $curstring =~ /<[\/a-z][^>]*$/ixsm ) {
1497            if ( $string =~ /^([^>]*>)(.*)/xsm ) {
1498                $curstring .= $1;
1499                $convertcut += length $1;
1500                if ($2) { $string = $2; goto CHECKAGAIN; }
1501            }
1502            else {
1503                $curstring .= "$string ";
1504                $convertcut += length($string) + 1;
1505            }
1506            next;
1507        }
1508
1509        # jump over YaBBC-tags if YaBBC is allowed
1510        if ( $enable_ubbc && $curstring =~ /\[[\/a-z][^\]]*$/ixsm ) {
1511            if ( $string =~ /^([^\]]*\])(.*)/xsm ) {
1512                $curstring .= $1;
1513                $convertcut += length $1;
1514                if ($2) { $string = $2; goto CHECKAGAIN; }
1515            }
1516            else {
1517                $curstring .= "$string ";
1518                $convertcut += length($string) + 1;
1519            }
1520            next;
1521        }
1522        $stinglength = length $string;
1523        $teststring  = $string;
1524
1525        # correct length for HTML characters
1526        FromHTML($teststring);
1527        $convertcut += $stinglength - length $teststring;
1528
1529        # correct length for special characters, YaBBC and HTML-Tags
1530        $teststring = $string;
1531        $teststring =~ s/\[ch\d{3,}?\]/ /igxsm;
1532        $teststring =~ s/<.*?>|\[.*?\]//gxsm;
1533        $convertcut += $stinglength - length $teststring;
1534
1535        $curstring .= "$string ";
1536        $curstring =~ s/ <br $/<br /ism;
1537
1538        if ( $curstring =~ /(<[\/a-z][^>]*)$/ism ) {
1539            $convertcut += length $1;
1540        }
1541        if ( $enable_ubbc && $curstring =~ /(\[[\/a-z][^\]]*)$/ism ) {
1542            $convertcut += length $1;
1543        }
1544
1545        if ( length($curstring) > $convertcut ) {
1546            $cliped = 1;
1547            last;
1548        }
1549    }
1550    if ( $curstring =~ /( *<[\/a-z][^>]*)$/ism
1551        || ( $enable_ubbc && $curstring =~ /( *\[[\/a-z][^\]]*)$/ism ) )
1552    {
1553        $convertcut -= length $1;
1554    }
1555    $convertstr = substr $curstring, 0, $convertcut;
1556
1557    # eliminate spaces, broken HTML-characters or special characters at the end
1558    $convertstr =~ s/(\[(ch\d*)?|&[a-z]*| +)$//sm;
1559    return;
1560}
1561
1562sub WrapChars {
1563    my @x = @_;
1564    my ( $tmpwrapstr, $length, $char, $curword, $tmpwrapcut );
1565    my $wrapcut = $x[1];
1566    foreach my $curword ( split /\s+/xsm, $x[0] ) {
1567        $char    = $curword;
1568        $length  = 0;
1569        $curword = q{};
1570        while ( $char ne q{} ) {
1571            if    ( $char =~ s/^(&#?[a-z\d]+;)//ism ) { $curword .= $1; }
1572            elsif ( $char =~ s/^(.)//sm )             { $curword .= $1; }
1573            $length++;
1574            if ( $length >= $wrapcut ) {
1575                $curword .= '<br />';
1576                $tmpwrapcut = $length = 0;
1577            }
1578        }
1579        if ( $tmpwrapstr && ( $tmpwrapcut + $length ) >= $wrapcut ) {
1580            $tmpwrapstr .= " $curword<br />";
1581            $tmpwrapcut = 0;
1582        }
1583        elsif ($tmpwrapstr) {
1584            $tmpwrapstr .= " $curword";
1585            $tmpwrapcut += $length + 1;
1586        }
1587        else {
1588            $tmpwrapstr = $curword;
1589            $tmpwrapcut = $length;
1590        }
1591    }
1592    $tmpwrapstr =~ s/(<br \/>)*$/<br \/>/sm;
1593    return $tmpwrapstr;
1594}
1595
1596# Out of: Escape.pm, v 3.28 2004/11/05 13:58:31
1597# Original Modul at: http://search.cpan.org/~gaas/URI-1.35/URI/Escape.pm
1598sub uri_escape {    # usage: $safe = uri_escape( $string )
1599    my $text = shift;
1600
1601    #    return undef unless defined $text;
1602    defined $text || return;
1603    if ( !%escapes ) {
1604
1605        # Build a char->hex map
1606        for ( 0 .. 255 ) { $escapes{ chr $_ } = sprintf '%%%02X', $_ }
1607    }
1608
1609    # Default unsafe characters. RFC 2732 ^(uric - reserved)
1610    $text =~ s/([^A-Za-z0-9\-_.!~*'()])/ $escapes{$1} || $1 /gesm;
1611
1612    #'; to keep my text editor happy;
1613    return $text;
1614}
1615
1616sub enc_eMail {
1617    my ($title,$email,$subject,$body,$src) = @_;
1618    my ($charset_value);
1619    if ($yymycharset eq 'windows-1251') { $charset_value = 848;} # Cyrillic decoding
1620
1621    my $email_length = length $email;
1622    my $code1 = generate_code($email_length);
1623    my $code2;
1624    for my $i ( 0 .. ( $email_length - 1 ) ) {
1625        $code2 .= chr( ord( substr $code1, $i, 1 )^ord( substr $email, $i, 1 ));
1626    }
1627    $code2 = uri_escape($code2);
1628
1629    *enc_eMail_x = sub {
1630        my ( $x, $y, $z ) = @_;
1631        if ( !$y ) {
1632            $x = ord $x;
1633            if ( $charset_value && $x > 126 ) { $x += $charset_value; }
1634            $x = "&#$x";
1635        }
1636        elsif ($z) {
1637            $x =~ s/"/\\"/gxsm;
1638        }
1639
1640        return $x;
1641    };
1642    my $subbody;
1643    if ($subject or $body) {
1644        $subject = uri_escape($subject);
1645        $body = uri_escape($body);
1646        $subbody = "?subject=$subject&body=$body";
1647        $subbody =~ s/(((<.+?>)|&#\d+;)|.)/ enc_eMail_x($1,$2,$3) /egsm;
1648    }
1649    $titlesp = $title;
1650    $titlesp =~ s/(((<.+?>)|&#\d+;)|.)/ enc_eMail_x($1,$2,$3) /egsm;
1651    if ($src || $yymycharset eq 'UTF-8') {$titlesp = $title;}
1652
1653    return qq~<script type='text/javascript'>\nSpamInator('$titlesp',"$code1","$code2","&#109;&#97;&#105;&#108;&#92;&#117;&#48;&#48;&#55;&#52;&#111;&#92;&#117;&#48;&#48;&#51;&#97;",'$subbody');\n</script>~;
1654
1655}
1656
1657sub generate_code {
1658    my ($arrey_in) = @_;
1659    my ( $arrey_pos, $code );
1660    my @arrey = (
1661        'a' .. 'q', 'C' .. 'O', '1' .. '9', 'g' .. 'u',
1662        'l' .. 'z', '9' .. '1', 'H' .. 'W',
1663    );
1664
1665    foreach my $i ( 0 .. ( $arrey_in - 1 ) ) {
1666        $arrey_pos = int rand $#arrey;
1667        $code .= $arrey[$arrey_pos];
1668    }
1669    return $code;
1670}
1671
1672sub FromChars {
1673    ( $_[0] ) = @_;
1674    ## This cannot be localized or unpacked ##
1675    $_[0] =~ s/&#(\d{3,});/ $1>127 ? "[ch$1]" : $& /egism;
1676
1677    return $_[0];
1678}
1679
1680sub ToChars {
1681    ( $_[0] ) = @_;
1682    ## This cannot be localized or unpacked ##
1683    $_[0] =~ s/\[ch(\d{3,})\]/ $1>127 ? "\&#$1;" : q{} /egism;
1684    return $_[0];
1685}
1686
1687sub ToHTML {
1688    ( $_[0] ) = @_;
1689    ## This cannot be localized or unpacked - damages smilies ##
1690    $_[0] =~ s/&/&amp;/gsm;
1691    $_[0] =~ s/\}/\&#125;/gsm;
1692    $_[0] =~ s/\{/\&#123;/gsm;
1693    $_[0] =~ s/\|/&#124;/gsm;
1694    $_[0] =~ s/>/&gt;/gsm;
1695    $_[0] =~ s/</&lt;/gsm;
1696    $_[0] =~ s/   /&nbsp; &nbsp;/gsm;
1697    $_[0] =~ s/  /&nbsp; /gsm;
1698    $_[0] =~ s/"/&quot;/gsm;            #" make my syntax checker happy;
1699    return $_[0];
1700}
1701
1702sub FromHTML {
1703    ( $_[0] ) = @_;
1704    ## This cannot be localized or unpacked ##
1705    $_[0] =~ s/&quot;/"/gsm;            #" make my syntax checker happy;
1706    $_[0] =~ s/&nbsp;/ /gsm;
1707    $_[0] =~ s/&lt;/</gsm;
1708    $_[0] =~ s/&gt;/>/gsm;
1709    $_[0] =~ s/&#124;/\|/gsm;
1710    $_[0] =~ s/&#123;/\{/gsm;
1711    $_[0] =~ s/&#125;/\}/gsm;
1712    $_[0] =~ s/&amp;/&/gsm;
1713    return $_[0];
1714}
1715
1716sub dopre {
1717    my ($inp) = @_;
1718    $inp =~ s/<br \/>/\n/gxsm;
1719    $inp =~ s/<br>/\n/gxsm;
1720    return $inp;
1721}
1722
1723sub Split_Splice_Move {
1724    my ( $s_s_m, $s_s_n ) = @_;
1725    my $ssm = 0;
1726    if ( !$s_s_n ) {    # Just for the subject of a message
1727        $s_s_m =~ s/^(Re: )?\[m.*?\]/$maintxt{'758'}/sm;
1728        return $s_s_m;
1729    }
1730    elsif ( $s_s_m =~ /\[m by=(.+?) destboard=(.+?) dest=(.+?)\]/sm )
1731    {                   # 'This Topic has been moved to' a different board
1732        my ( $mover, $destboard, $dest ) = ( $1, $2, $3 );
1733
1734        # Who moved the topic; destination board; destination id number
1735        $mover = decloak($mover);
1736        LoadUser($mover);
1737        $board{$destboard} =~ /^(.+?)\|/xsm;
1738        return (
1739qq~<b>$maintxt{'160'} <a href="$scripturl?num=$dest"><b>$maintxt{'160a'}</b></a> $maintxt{'160b'}</b> <a href="$scripturl?board=$destboard"><i><b>$1</b></i></a><b> $maintxt{'525'} <i>${$uid.$mover}{'realname'}</i></b>~,
1740            $dest
1741        );
1742    }
1743    elsif ( $s_s_m =~ /\[m by=(.+?) dest=(.+?)\]/sm )
1744    {    # 'The contents of this Topic have been moved to''this Topic'
1745        my ( $mover, $dest ) =
1746          ( $1, $2 );    # Who moved the topic; destination id number
1747        $mover = decloak($mover);
1748        LoadUser($mover);
1749        return (
1750qq~<b>$maintxt{'160c'}</b> <a href="$scripturl?num=$dest"><i><b>$maintxt{'160d'}</b></i></a><b> $maintxt{'525'} <i>${$uid.$mover}{'realname'}</i></b>~,
1751            $dest
1752        );
1753    }
1754    elsif ( $s_s_m =~ /^\[m\]/sm )
1755    {    # Old style topic that was moved/spliced before this code
1756        fopen( MOVEDFILE, "$datadir/$_[1].txt" );
1757        (
1758            undef, undef, undef, undef,  undef,
1759            undef, undef, undef, $s_s_m, undef
1760        ) = split /\|/xsm, <MOVEDFILE>, 10;
1761        fclose(MOVEDFILE);
1762        ToChars($s_s_m);
1763        $ssm = 1;
1764    }
1765
1766    $ssm += $s_s_m =~ s/\[spliced\]/$maintxt{'160c'}/gxsm;
1767
1768    # The contents of this Topic have been moved to
1769    $ssm += $s_s_m =~
1770      s/\[splicedhere\]|\[splithere\]/$maintxt{'160d'}/gxsm;    # this Topic
1771    $ssm += $s_s_m =~
1772      s/\[split\]/$maintxt{'160e'}/gxsm;  # Off-Topic replies have been moved to
1773    $ssm += $s_s_m =~ s/\[splithere_end\]/$maintxt{'160f'}/gxsm;    # .
1774    $ssm +=
1775      $s_s_m =~ s/\[moved\]/$maintxt{'160'}/gxsm; # This Topic has been moved to
1776    $ssm += $s_s_m =~
1777      s/\[movedhere\]/$maintxt{'161'}/gxsm;    # This Topic was moved here from
1778    $ssm += $s_s_m =~ s/\[postsmovedhere1\]/$maintxt{'161a'}/gxsm;    # The last
1779    $ssm += $s_s_m =~
1780      s/\[postsmovedhere2\]/$maintxt{'161b'}/gxsm;  # Posts were moved here from
1781    $ssm += $s_s_m =~ s/\[move by\]/$maintxt{'525'}/gxsm;    # by
1782
1783    if ($ssm) {    # only if it was an internal s_s_m info
1784        $s_s_m =~
1785s/\[link=\s*(\S\w+\:\/\/\S+?)\s*\](.+?)\[\/link\]/<a href="$1">$2<\/a>/gxsm;
1786        $s_s_m =~
1787s/\[link=\s*(\S+?)\](.+?)\s*\[\/link\]/<a href="http:\/\/$1">$2<\/a>/gxsm;
1788        $s_s_m =~ s/\[b\](.*?)\[\/b\]/<b>$1<\/b>/gxsm;
1789        $s_s_m =~ s/\[i\](.*?)\[\/i\]/<i>$1<\/i>/gxsm;
1790    }
1791    return ( $s_s_m, $ssm );
1792}
1793
1794sub elimnests {
1795    my ($inp) = @_;
1796    $inp =~ s/\[\/*shadow([^\]]*)\]//igxsm;    #*/;
1797    $inp =~ s/\[\/*glow([^\]]*)\]//igxsm;      #*/;
1798    return $inp;
1799}
1800
1801sub unwrap {
1802    my ( $codelang, $unwrapped ) = @_;
1803    $unwrapped =~ s/<yabbwrap>//gxsm;
1804    $unwrapped = qq~\[code$codelang\]$unwrapped\[\/code\]~;
1805    return $unwrapped;
1806}
1807
1808sub wrap {
1809    if ($newswrap) { $linewrap = $newswrap; }
1810    $message =~ s/ &nbsp; &nbsp; &nbsp;/\[tab\]/igsm;
1811    $message =~ s/<br \/>/\n/gsm;
1812    $message =~ s/<br>/\n/gxsm;
1813    $message =~ s/((\[ch\d{3,}?\]){$linewrap})/$1\n/igsm;
1814
1815    FromHTML($message);
1816    $message =~ s/[\n\r]/ <yabbbr> /gsm;
1817    my @words = split /\s/xsm, $message;
1818    $message = q{};
1819    foreach my $cur (@words) {
1820        if (   $cur !~ m{www\.(\S+?)\.}xsm
1821            && $cur !~ m{[ht|f]tp://}xsm
1822            && $cur !~ m{\[\S*\]}xsm
1823            && $cur !~ m{\[\S*\s?\S*?\]}xsm
1824            && $cur !~ m{\[\/\S*\]}xsm )
1825        {
1826            $cur =~ s/(\S{$linewrap})/$1\n/gism;
1827        }
1828        if (   $cur !~ m{\[table(\S*)\](\S*)\[\/table\]}xsm
1829            && $cur !~ m{\[url(\S*)\](\S*)\[\/url\]}xsm
1830            && $cur !~ m{\[flash(\S*)\](\S*)\[\/flash\]}xsm
1831            && $cur !~ m{\[img(\S*)\](\S*)\[\/img\]}xsm )
1832        {
1833            $cur =~ s/(\[\S*?\])/ $1 /gxsm;
1834            @splitword = split /\s/xsm, $cur;
1835            $cur = q{};
1836            foreach my $splitcur (@splitword) {
1837                if (   $splitcur !~ m{www\.(\S+?)\.}xsm
1838                    && $splitcur !~ m{[ht|f]tp://}xsm
1839                    && $splitcur !~ m{\[\S*\]}xsm )
1840                {
1841                    $splitcur =~ s/(\S{$linewrap})/$1<yabbwrap>/gism;
1842                }
1843                $cur .= $splitcur;
1844            }
1845        }
1846        $message .= "$cur ";
1847    }
1848    $message =~ s/\[code((?:\s*).*?)\](.*?)\[\/code\]/unwrap($1,$2)/eisgm;
1849    $message =~ s/ <yabbbr> /\n/gsm;
1850    $message =~ s/<yabbwrap>/\n/gsm;
1851
1852    ToHTML($message);
1853    $message =~ s/\[tab\]/ &nbsp; &nbsp; &nbsp;/igsm;
1854    $message =~ s/\n/<br \/>/gsm;
1855    return;
1856}
1857
1858sub wrap2 {
1859    $message =~
1860s/<a href=(\S*?)(\s[^>]*)?>(\S*?)<\/a>/ my ($mes,$out,$i) = ($3,q{},1); { while ($mes ne q{}) { if ($mes =~ s\/^(<.+?>)\/\/) { $out .= $1; } elsif ($mes =~ s\/^(&.+?;|\[ch\d{3,}\]|.)\/\/) { last if $i > $linewrap; $i++; $out .= $1; if ($mes eq q{}) { $i--; last; } } } } "<a href=$1$2>$out" . ($i > $linewrap ? q{...} : q{}) . '<\/a>' /eigsm;
1861    return;
1862}
1863
1864sub MembershipGet {
1865    if ( fopen( FILEMEMGET, "$memberdir/members.ttl" ) ) {
1866        $_ = <FILEMEMGET>;
1867        chomp;
1868        fclose(FILEMEMGET);
1869        return split /\|/xsm, $_;
1870    }
1871    else {
1872        my @ttlatest = MembershipCountTotal();
1873        return @ttlatest;
1874    }
1875}
1876
1877{
1878    my %yyOpenMode = (
1879        '+>>' => 5,
1880        '+>'  => 4,
1881        '+<'  => 3,
1882        '>>'  => 2,
1883        '>'   => 1,
1884        '<'   => 0,
1885        q{}   => 0,
1886    );
1887
1888    # fopen: opens a file. Allows for file locking and better error-handling.
1889    sub fopen ($$;$) {
1890        my ( $filehandle, $filename, $usetmp ) = @_;
1891        my ( $pack,       $file,     $line )   = caller;
1892        $file_open++;
1893        ## make life easier - spot a file that is not closed!
1894        if ($debug) {
1895            LoadLanguage('Debug');
1896            $openfiles .=
1897                qq~$filehandle (~
1898              . sprintf( '%.4f', ( time - $START_TIME ) )
1899              . qq~)     $filename~;
1900        }
1901        my ( $flockCorrected, $cmdResult, $openMode, $openSig );
1902
1903        $serveros = $OSNAME;    #"$^O";
1904                                #magic punctuation variable BAD #
1905        if ( $serveros =~ m/Win/sm && substr( $filename, 1, 1 ) eq q{:} ) {
1906            $filename =~ s/\\/\\\\/gxsm;
1907
1908        # Translate windows-style \ slashes to windows-style \\ escaped slashes.
1909            $filename =~ s/\//\\\\/gxsm;
1910
1911           # Translate unix-style / slashes to windows-style \\ escaped slashes.
1912        }
1913        else {
1914            $filename =~ tr~\\~/~;
1915
1916            # Translate windows-style \ slashes to unix-style / slashes.
1917        }
1918        $LOCK_EX     = 2; # You can probably keep this as it is set now.
1919        $LOCK_UN     = 8; # You can probably keep this as it is set now.
1920        $LOCK_SH     = 1; # You can probably keep this as it is set now.
1921        $usetempfile = 0; # Write to a temporary file when updating large files.
1922
1923        # Check whether we want write, append, or read.
1924        if ( $filename =~ m/\A([<>+]*)(.+)/sm ) {
1925            $openSig  = $1 || q{};
1926            $filename = $2 || $filename;
1927        }
1928        $openMode = $yyOpenMode{$openSig} || 0;
1929
1930        $filename =~ s/[^\/\\0-9A-Za-z#%+\,\-\ \.\:@^_]//gxsm;
1931
1932        # Remove all inappropriate characters.
1933
1934        if ( $filename =~ m{/\.\./}sm ) {
1935            fatal_error( 'cannot_open', "$filename. $maintxt{'609'}" );
1936        }
1937
1938# If the file doesn't exist, but a backup does, rename the backup to the filename
1939        if ( !-e $filename && -e "$filename.bak" ) {
1940            rename "$filename.bak", "$filename";
1941        }
1942        if ( -z $filename && -e "$filename.bak" ) {
1943            rename "$filename.bak", "$filename";
1944        }
1945
1946        $testfile = $filename;
1947        if ( $use_flock == 2 && $openMode ) {
1948            my $count;
1949            while ( $count < 15 ) {
1950                if   ( -e $filehandle ) { sleep 2; }
1951                else                    { last; }
1952                ++$count;
1953            }
1954            if ( $count == 15 ) { unlink $filehandle; }
1955            *LFH = undef;
1956            CORE::open( LFH, ">$filehandle" );
1957            $yyLckFile{$filehandle} = *LFH;
1958        }
1959
1960        if (   $use_flock
1961            && $openMode == 1
1962            && $usetmp
1963            && $usetempfile
1964            && -e $filename )
1965        {
1966            $yyTmpFile{$filehandle} = $filename;
1967            $filename .= '.tmp';
1968        }
1969
1970        if ( $openMode > 2 ) {
1971            if ( $openMode == 5 ) {
1972                $cmdResult = CORE::open( $filehandle, "+>>$filename" );
1973            }
1974            elsif ( $use_flock == 1 ) {
1975                if ( $openMode == 4 ) {
1976                    if ( -e $filename ) {
1977
1978                     # We are opening for output and file locking is enabled...
1979                     # read-open() the file rather than write-open()ing it.
1980                     # This is to prevent open() from clobbering the file before
1981                     # checking if it is locked.
1982                        $flockCorrected = 1;
1983                        $cmdResult = CORE::open( $filehandle, "+<$filename" );
1984                    }
1985                    else {
1986                        $cmdResult = CORE::open( $filehandle, "+>$filename" );
1987                    }
1988                }
1989                else {
1990                    $cmdResult = CORE::open( $filehandle, "+<$filename" );
1991                }
1992            }
1993            elsif ( $openMode == 4 ) {
1994                $cmdResult = CORE::open( $filehandle, "+>$filename" );
1995            }
1996            else {
1997                $cmdResult = CORE::open( $filehandle, "+<$filename" );
1998            }
1999        }
2000        elsif ( $openMode == 1 && $use_flock == 1 ) {
2001            if ( -e $filename ) {
2002
2003                # We are opening for output and file locking is enabled...
2004                # read-open() the file rather than write-open()ing it.
2005                # This is to prevent open() from clobbering the file before
2006                # checking if it is locked.
2007                $flockCorrected = 1;
2008                $cmdResult = CORE::open( $filehandle, "+<$filename" );
2009            }
2010            else {
2011                $cmdResult = CORE::open( $filehandle, ">$filename" );
2012            }
2013        }
2014        elsif ( $openMode == 1 ) {
2015            $cmdResult = CORE::open( $filehandle, ">$filename" );
2016
2017            # Open the file for writing
2018        }
2019        elsif ( $openMode == 2 ) {
2020            $cmdResult = CORE::open( $filehandle, ">>$filename" );
2021
2022            # Open the file for append
2023        }
2024        elsif ( $openMode == 0 ) {
2025            $cmdResult =
2026              CORE::open( $filehandle, $filename );    # Open the file for input
2027        }
2028        if ( !$cmdResult ) { return 0; }
2029        if ($flockCorrected) {
2030
2031# The file was read-open()ed earlier, and we have now verified an exclusive lock.
2032# We shall now clobber it.
2033            flock $filehandle, $LOCK_EX;
2034            if ($faketruncation) {
2035                CORE::open( OFH, ">$filename" );
2036                if ( !$cmdResult ) { return 0; }
2037                print {OFH} q{} or croak "$croak{'print'} OFH";
2038                CORE::close(OFH);
2039            }
2040            else {
2041                truncate( *{$filehandle}, 0 )
2042                  or fatal_error( 'truncation_error', "$filename" );
2043            }
2044            seek $filehandle, 0, 0;
2045        }
2046        elsif ( $use_flock == 1 ) {
2047            if   ($openMode) { flock $filehandle, $LOCK_EX; }
2048            else             { flock $filehandle, $LOCK_SH; }
2049        }
2050        return 1;
2051    }
2052
2053# fclose: closes a file, using Windows 95/98/ME-style file locking if necessary.
2054    sub fclose ($) {
2055        my ($filehandle) = @_;
2056        my ( $pack, $file, $line ) = caller;
2057        $file_close++;
2058        if ($debug) {
2059            LoadLanguage('Debug');
2060            $openfiles .=
2061                qq~     $filehandle (~
2062              . sprintf( '%.4f', ( time - $START_TIME ) )
2063              . qq~)\n[$pack, $file, $line]\n\n~;
2064        }
2065        CORE::close($filehandle);
2066        if ( $use_flock == 2 ) {
2067            if ( exists $yyLckFile{$filehandle} && -e $filehandle ) {
2068                CORE::close( $yyLckFile{$filehandle} );
2069                unlink $filehandle;
2070                delete $yyLckFile{$filehandle};
2071            }
2072        }
2073        if ( $yyTmpFile{$filehandle} ) {
2074            my $bakfile = $yyTmpFile{$filehandle};
2075            if ( $use_flock == 1 ) {
2076
2077                # Obtain an exclusive lock on the file.
2078                # ie: wait for other processes to finish...
2079                *FH = undef;
2080                CORE::open( FH, $bakfile );
2081                flock FH, $LOCK_EX;
2082                CORE::close(FH);
2083            }
2084
2085            # Switch the temporary file with the original.
2086            if ( -e "$bakfile.bak" ) { unlink "$bakfile.bak"; }
2087            rename $bakfile, "$bakfile.bak";
2088            rename "$bakfile.tmp", $bakfile;
2089            delete $yyTmpFile{$filehandle};
2090            if ( -e $bakfile ) {
2091                unlink "$bakfile.bak";
2092
2093                # Delete the original file to save space.
2094            }
2095        }
2096        return 1;
2097    }
2098
2099}    # / my %yyOpenMode
2100
2101sub KickGuest {
2102    require Sources::LogInOut;
2103    $sharedLogin_title = "$maintxt{'633'}";
2104    $sharedLogin_text =
2105qq~<br />$maintxt{'634'}<br />$maintxt{'635'} <a href="$scripturl?action=register">$maintxt{'636'}</a> $maintxt{'637'}<br /><br />~;
2106    $yymain .= sharedLogin();
2107    $yytitle = "$maintxt{'34'}";
2108    template();
2109    return;
2110}
2111
2112sub WriteLog {
2113    if (   $action eq 'ajxmessage'
2114        || $action eq 'ajximmessage'
2115        || $action eq 'ajxcal' )
2116    {
2117        return;
2118    }
2119
2120    # comment out (#) the next line if you have problems with
2121    # 'Reverse DNS lookup timeout causes slow page loads'
2122    # (http://www.yabbforum.com/community/YaBB.pl?num=1199991357)
2123    # Search Engine identification and display will be turned off
2124    my $user_host =
2125      ( gethostbyaddr pack( 'C4', split /\./xsm, $user_ip ), 2 )[0];
2126
2127    my ( $name, $logtime, @new_log );
2128    my $onlinetime = $date - ( $OnlineLogTime * 60 );
2129    my $field = $username;
2130    if ( $field eq 'Guest' ) {
2131        if ($guestaccess) { $field = $user_ip; }
2132        else              { return; }
2133    }
2134
2135    fopen( LOG, "<$vardir/log.txt" );
2136    @logentries = <LOG>;    # Global variable
2137    fclose( LOG );
2138    foreach (@logentries) {
2139        ( $name, $logtime, undef ) = split /\|/xsm, $_, 3;
2140        if ( $name ne $user_ip && $name ne $field && $logtime >= $onlinetime ) {
2141            push @new_log, $_;
2142        }
2143    }
2144   fopen( LOG, ">$vardir/log.txt" );
2145    print {LOG} (
2146"$field|$date|$user_ip|$user_host#$ENV{'HTTP_USER_AGENT'}|$username|$currentboard|"
2147          . (
2148            ( !$action && $INFO{'num'} && $currentboard )
2149            ? 'display'
2150            : (
2151                (
2152                        !$action
2153                      && $ENV{'SCRIPT_FILENAME'} =~ /\/AdminIndex\.(pl|cgi)/sm
2154                ) ? 'admincenter' : $action
2155            )
2156          )
2157          . "|$INFO{'username'}|$curnum\n",
2158        @new_log
2159    ) or croak qq~$croak{'print'} log.txt~;
2160    fclose(LOG);
2161
2162    if ( !$action && $enableclicklog == 1 ) {
2163        $onlinetime = $date - ( $ClickLogTime * 60 );
2164        fopen( LOG, "<$vardir/clicklog.txt", 1 );
2165        @new_log = <LOG>;
2166        fclose( LOG );
2167        fopen( LOG, ">$vardir/clicklog.txt", 1 );
2168        print {LOG} "$field|$date|$ENV{'REQUEST_URI'}|"
2169          . (
2170            $ENV{'HTTP_REFERER'} =~ m/$boardurl/ism
2171            ? q{}
2172            : $ENV{'HTTP_REFERER'}
2173          )
2174          . "|$ENV{'HTTP_USER_AGENT'}\n"
2175          or croak "$croak{'print'} LOG";
2176        foreach (@new_log) {
2177            if ( ( split /\|/xsm, $_, 3 )[1] >= $onlinetime ) {
2178                print {LOG} $_ or croak "$croak{'print'} LOG";
2179            }
2180        }
2181        fclose(LOG);
2182    }
2183    return;
2184}
2185
2186sub RemoveUserOnline {
2187    my $user = shift;
2188    fopen( LOG, "<$vardir/log.txt", 1 );
2189    @logentries = <LOG>;    # Global variable
2190    fclose( LOG );
2191    fopen( LOG, ">$vardir/log.txt", 1 );
2192    if ($user) {
2193        my $x = -1;
2194        for my $i ( 0 .. ( @logentries - 1 ) ) {
2195            if ( ( split /\|/xsm, $logentries[$i], 2 )[0] ne $user ) {
2196                print {LOG} $logentries[$i] or croak "$croak{'print'} LOG";
2197            }
2198            elsif ( $user eq $username ) {
2199                $logentries[$i] =~ s/^$user\|/$user_ip\|/xsm;
2200                print {LOG} $logentries[$i] or croak "$croak{'print'} LOG";
2201            }
2202            else { $x = $i; }
2203        }
2204        if ( $x > -1 ) { splice @logentries, $x, 1; }
2205    }
2206    else {
2207        print {LOG} q{} or croak "$croak{'print'} LOG";
2208        @logentries = ();
2209    }
2210    fclose(LOG);
2211    return;
2212}
2213
2214sub encode_password {
2215    my ($eol) = @_;
2216    chomp $eol;
2217    require Digest::MD5;
2218    import Digest::MD5 qw(md5_base64);
2219    return md5_base64($eol);
2220}
2221
2222sub Censor {
2223    my ($string) = @_;
2224    foreach my $censor (@censored) {
2225        my ( $tmpa, $tmpb, $tmpc ) = @{$censor};
2226        if ($tmpc) {
2227            $string =~
2228              s/(^|\W|_)\Q$tmpa\E(?=$|\W|_)/$1$tmpb/gism;
2229        }
2230        else {
2231            $string =~ s/\Q$tmpa\E/$tmpb/gism;
2232        }
2233    }
2234    return $string;
2235}
2236
2237sub CheckCensor {
2238    my ($string) = @_;
2239    foreach my $censor (@censored) {
2240        my ( $tmpa, $tmpb, $tmpc ) = @{$censor};
2241        if ( $string =~ m/(\Q$tmpa\E)/ixsm ) {
2242            $found_word .= "$1 ";
2243        }
2244    }
2245    return $found_word;
2246}
2247
2248sub referer_check {
2249    return if !$action;
2250    my $referencedomain = substr $boardurl, 7, ( index $boardurl, q{/}, 7 ) - 7;
2251    my $refererdomain = substr $ENV{HTTP_REFERER}, 7,
2252      ( index $ENV{HTTP_REFERER}, q{/}, 7 ) - 7;
2253    if (   $refererdomain !~ /$referencedomain/sm
2254        && $ENV{QUERY_STRING} ne q{}
2255        && length($refererdomain) > 0 )
2256    {
2257        my $goodaction = 0;
2258        fopen( ALLOWED, "$vardir/allowed.txt" );
2259        my @allowed = <ALLOWED>;
2260        fclose(ALLOWED);
2261        foreach my $allow (@allowed) {
2262            chomp $allow;
2263            if ( $action eq $allow ) { $goodaction = 1; last; }
2264        }
2265        if ( !$goodaction ) {
2266            fatal_error( 'referer_violation',
2267"$action<br />$reftxt{'7'} $referencedomain<br />$reftxt{'6'} $refererdomain"
2268            );
2269        }
2270    }
2271    return;
2272}
2273
2274sub Dereferer {
2275    if ( !$stealthurl ) { fatal_error('no_access'); }
2276    if ($yycharset) {$yymycharset = $yycharset;}
2277    print "Content-Type: text/html\n\n" or croak "$croak{'print'} content-type";
2278    print
2279qq~<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">\n<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="$abbr_lang" lang="$abbr_lang">\n<head>\n<meta http-equiv="Content-Type" content="text/html; charset=$yymycharset" />\n<title>-----</title>\n</head>\n<body onload="window.location.href='$INFO{'url'}';">\n<span style="font-family:Arial; font-size:medium">$dereftxt{'1'}</span>\n</body></html>\n~
2280      or croak "$croak{'print'}";
2281    exit;
2282}
2283
2284sub LoadLanguage {
2285    my ($what_to_load) = @_;
2286    my $use_lang = $language ? $language : $lang;
2287    if ( -e "$langdir/$use_lang/$what_to_load.lng" ) {
2288        require "$langdir/$use_lang/$what_to_load.lng";
2289    }
2290    elsif ( -e "$langdir/$lang/$what_to_load.lng" ) {
2291        require "$langdir/$lang/$what_to_load.lng";
2292    }
2293    elsif ( -e "$langdir/English/$what_to_load.lng" ) {
2294        require "$langdir/English/$what_to_load.lng";
2295    }
2296    else {
2297
2298       # Catches deep recursion problems
2299       # We can simply return to the error routine once we add the needed string
2300        if ( $what_to_load eq 'Error' ) {
2301            %error_txt = (
2302                'cannot_open_language' =>
2303'Cannot find required language file. Please inform the administrator about this problem.',
2304                'error_description' => 'An Error Has Occurred!',
2305            );
2306            return;
2307        }
2308
2309        fatal_error( 'cannot_open_language', "$use_lang/$what_to_load.lng" );
2310    }
2311    return;
2312}
2313
2314sub Recent_Load {
2315    my ($who_to_load) = @_;
2316    undef %recent;
2317    if ( -e "$memberdir/$who_to_load.rlog" ) {
2318        fopen( RLOG, "$memberdir/$who_to_load.rlog" );
2319        my %r = map { /(.*)\t(.*)/xsm } <RLOG>;
2320        fclose(RLOG);
2321        map { @{ $recent{$_} } = split /,/xsm, $r{$_} } keys %r;
2322    }
2323    elsif ( -e "$memberdir/$who_to_load.wlog" ) {
2324        require "$memberdir/$who_to_load.wlog";
2325        fopen( RLOG, ">$memberdir/$who_to_load.rlog" );
2326        print {RLOG} map { "$_\t$recent{$_}\n" } keys %recent
2327          or croak "$croak{'print'} RLOG";
2328        fclose(RLOG);
2329        unlink "$memberdir/$who_to_load.wlog";
2330        Recent_Load($who_to_load);
2331    }
2332    return;
2333}
2334
2335sub Recent_Write {
2336    my ( $todo, $recentthread, $recentuser, $recenttime ) = @_;
2337    Recent_Load($recentuser);
2338    if ( $todo eq 'incr' ) {
2339        ${ $recent{$recentthread} }[0]++;
2340        ${ $recent{$recentthread} }[1] = $recenttime;
2341    }
2342    elsif ( $todo eq 'decr' ) {
2343        ${ $recent{$recentthread} }[0]--;
2344        if ( ${ $recent{$recentthread} }[0] < 1 ) {
2345            delete $recent{$recentthread};
2346        }
2347        else { ${ $recent{$recentthread} }[1] = $recenttime; }
2348    }
2349    Recent_Save($recentuser);
2350    return;
2351}
2352
2353sub Recent_Save {
2354    my ($who_to_save) = @_;
2355    if ( !%recent ) {
2356        unlink "$memberdir/$who_to_save.rlog";
2357        return;
2358    }
2359    fopen( RLOG, ">$memberdir/$who_to_save.rlog" );
2360    print {RLOG} map { "$_\t" . join( q{,}, @{ $recent{$_} } ) . "\n" }
2361      keys %recent
2362      or croak "$croak{'print'} RLOG";
2363    fclose(RLOG);
2364    return;
2365}
2366
2367sub save_moved_file {
2368
2369   # This sub saves the hash for the moved files: key == old id, value == new id
2370    fopen( MOVEDFILE, ">$vardir/Movedthreads.pm" )
2371      or fatal_error( 'cannot_open', "$vardir/Movedthreads.pm", 1 );
2372    print {MOVEDFILE} '%moved_file = ('
2373      . join( q{,},
2374        map { qq~"$_","$moved_file{$_}"~ }
2375          grep { ( $_ > 0 && $moved_file{$_} > 0 && $_ != $moved_file{$_} ) }
2376          keys %moved_file )
2377      . ");\n1;"
2378      or croak "$croak{'print'} MOVEDFILE";
2379    fclose(MOVEDFILE);
2380    return;
2381}
2382
2383sub Write_ForumMaster {
2384    fopen( FORUMMASTER, ">$boardsdir/forum.master", 1 );
2385    print {FORUMMASTER} qq~\$mloaded = 1;\n~
2386      or croak "$croak{'print'} FORUMMASTER";
2387    @catorder = undupe(@categoryorder);
2388    print {FORUMMASTER} qq~\@categoryorder = qw(@catorder);\n~
2389      or croak "$croak{'print'} FORUMMASTER";
2390    my ( $key, $value );
2391    while ( ( $key, $value ) = each %cat ) {
2392        %seen = ();
2393        @catval = split /\,/xsm, $value;
2394        @unique = grep { !$seen{$_} ++ } @catval;
2395        $val2 = join ',', @unique;
2396
2397        print {FORUMMASTER} qq~\$cat{'$key'} = qq\~$val2\~;\n~
2398          or croak "$croak{'print'} FORUMMASTER";
2399    }
2400    while ( ( $key, $value ) = each %catinfo ) {
2401        my ( $catname, $therest ) = split /\|/xsm, $value, 2;
2402
2403        #$catname =~ s/\&(?!amp;)/\&amp;$1/g;
2404        # We can rely on the admin scripts to properly encode when needed.
2405        $value = "$catname|$therest";
2406
2407        # Escape membergroups with a $ in them
2408        $value =~ s/\$/\\\$/gxsm;
2409
2410        # Strip membergroups with a ~ from them
2411        $value =~ s/\~//gxsm;
2412        print {FORUMMASTER} qq~\$catinfo{'$key'} = qq\~$value\~;\n~
2413          or croak "$croak{'print'} FORUMMASTER";
2414    }
2415    while ( ( $key, $value ) = each %board ) {
2416        my ( $boardname, $therest ) = split /\|/xsm, $value, 2;
2417
2418        #$boardname =~ s/\&(?!amp;)/\&amp;$1/g;
2419        # We can rely on the admin scripts to properly encode when needed.
2420        $value = "$boardname|$therest";
2421
2422        # Escape membergroups with a $ in them
2423        $value =~ s/\$/\\\$/gxsm;
2424
2425        # Strip membergroups with a ~ from them
2426        $value =~ s/\~//gxsm;
2427        print {FORUMMASTER} qq~\$board{'$key'} = qq\~$value\~;\n~
2428          or croak "$croak{'print'} FORUMMASTER";
2429    }
2430    while ( ( $key, $value ) = each %subboard ) {
2431        if ( $value ne q{} ) {
2432            print {FORUMMASTER} qq~\$subboard{'$key'} = qq\~$value\~;\n~
2433              or croak "$croak{'print'} FORUMMASTER";
2434        }
2435    }
2436    print {FORUMMASTER} qq~\n1;~ or croak "$croak{'print'} FORUMMASTER";
2437    fclose(FORUMMASTER);
2438    return;
2439}
2440
2441sub dirsize {
2442    my ($drsz) = @_;
2443    my $dirsize;
2444    require File::Find;
2445    import File::Find;
2446    find( sub { $dirsize += -s }, $drsz );
2447    return $dirsize;
2448}
2449
2450sub MemberPageindex {
2451    my ( $msindx, $trindx, $mbindx, $pmindx ) =
2452      split /\|/xsm, ${ $uid . $username }{'pageindex'};
2453    if ( $INFO{'action'} eq 'memberpagedrop' ) {
2454        ${ $uid . $username }{'pageindex'} = qq~$msindx|$trindx|0|$pmindx~;
2455    }
2456    if ( $INFO{'action'} eq 'memberpagetext' ) {
2457        ${ $uid . $username }{'pageindex'} = qq~$msindx|$trindx|1|$pmindx~;
2458    }
2459    UserAccount( $username, 'update' );
2460    my $SearchStr = $FORM{'member'} || $INFO{'member'};
2461    if ( $SearchStr ne q{} ) { $findmember = qq~;member=$SearchStr~; }
2462    if ( !$INFO{'from'} ) {
2463        $yySetLocation =
2464qq~$scripturl?action=ml;sort=$INFO{'sort'};letter=$INFO{'letter'};start=$INFO{'start'}$findmember~;
2465    }
2466    elsif ( $INFO{'from'} eq 'imlist' ) {
2467        $yySetLocation =
2468qq~$scripturl?action=imlist;sort=$INFO{'sort'};letter=$INFO{'letter'};start=$INFO{'start'};field=$INFO{'field'}~;
2469    }
2470    elsif ( $INFO{'from'} eq 'admin' ) {
2471        $yySetLocation =
2472qq~$adminurl?action=ml;sort=$INFO{'sort'};letter=$INFO{'letter'};start=$INFO{'start'}~;
2473    }
2474
2475    redirectexit();
2476    return;
2477}
2478
2479#changed sub for improved performance, code from Zoo
2480sub check_existence {
2481    my ( $dir, $filename ) = @_;
2482    my ( $origname, $filext );
2483
2484    if ( $filename =~ /(\S+?)(\.\S+$)/sm ) {
2485        $origname = $1;
2486        $filext   = $2;
2487    }
2488    my $numdelim = '_';
2489    my $filenumb = 0;
2490    while ( -e "$dir/$filename" ) {
2491        $filenumb = sprintf '%03d', ++$filenumb;
2492        $filename = qq~$origname$numdelim$filenumb$filext~;
2493    }
2494    return ($filename);
2495}
2496
2497sub ManageMemberlist {
2498    my ( $todo, $user, $userreg ) = @_;
2499    if (   $todo eq 'load'
2500        || $todo eq 'update'
2501        || $todo eq 'delete'
2502        || $todo eq 'add' )
2503    {
2504        fopen( MEMBLIST, "$memberdir/memberlist.txt" );
2505        %memberlist = map { /(.*)\t(.*)/m } <MEMBLIST>;
2506        fclose(MEMBLIST);
2507    }
2508    if ( $todo eq 'add' ) {
2509        $memberlist{$user} = "$userreg";
2510
2511    }
2512    elsif ( $todo eq 'update' ) {
2513        $memberlist{$user} = $userreg ? $userreg : $memberlist{$user};
2514
2515    }
2516    elsif ( $todo eq 'delete' ) {
2517        if ( $user =~ /,/sm ) {    # been sent a list to kill, not a single
2518            my @oldusers = split /,/xsm, $user;
2519            foreach my $user (@oldusers) {
2520                delete $memberlist{$user};
2521            }
2522        }
2523        else { delete $memberlist{$user}; }
2524    }
2525    if (   $todo eq 'save'
2526        || $todo eq 'update'
2527        || $todo eq 'delete'
2528        || $todo eq 'add' )
2529    {
2530        fopen( MEMBLIST, ">$memberdir/memberlist.txt" );
2531        print {MEMBLIST} map { "$_\t$memberlist{$_}\n" }
2532          sort { $memberlist{$a} <=> $memberlist{$b} } keys %memberlist
2533          or croak "$croak{'print'} MEMBLIST";
2534        fclose(MEMBLIST);
2535        undef %memberlist;
2536    }
2537    return;
2538}
2539
2540## deal with basic member data in memberinfo.txt
2541sub ManageMemberinfo {
2542    my ( $todo, $user, $userdisp, $usermail, $usergrp, $usercnt, $useraddgrp ) =
2543      @_;
2544    ## pull hash of member name + other data
2545    if (   $todo eq 'load'
2546        || $todo eq 'update'
2547        || $todo eq 'delete'
2548        || $todo eq 'add' )
2549    {
2550        fopen( MEMBINFO, "$memberdir/memberinfo.txt" );
2551        @membinfo = <MEMBINFO>;
2552        chomp @membinfo;
2553        %memberinf = map { /(.*)\t(.*)/xsm } @membinfo;
2554        fclose(MEMBINFO);
2555    }
2556    if ( $todo eq 'add' ) {
2557        $memberinf{$user} = "$userdisp|$usermail|$usergrp|$usercnt|$useraddgrp";
2558    }
2559    elsif ( $todo eq 'update' ) {
2560        ( $memrealname, $mememail, $memposition, $memposts, $memaddgrp ) =
2561          split /\|/xsm, $memberinf{$user};
2562        if ($userreg)  { $regdate     = $userreg; }
2563        if ($userdisp) { $memrealname = $userdisp; }
2564        if ($usermail) { $mememail    = $usermail; }
2565        if ($usergrp)  { $memposition = $usergrp; }
2566        if ($usercnt)  { $memposts    = $usercnt; }
2567        if ($useraddgrp) {
2568            if ( $useraddgrp =~ /###blank###/sm ) { $useraddgrp = q{}; }
2569            $memaddgrp = $useraddgrp;
2570        }
2571        $memberinf{$user} =
2572          "$memrealname|$mememail|$memposition|$memposts|$memaddgrp";
2573    }
2574    elsif ( $todo eq 'delete' ) {
2575        if ( $user =~ /,/xsm ) {    # been sent a list to kill, not a single
2576            my @oldusers = split /,/xsm, $user;
2577            foreach my $user (@oldusers) {
2578                delete $memberinf{$user};
2579            }
2580        }
2581        delete $memberinf{$user};
2582    }
2583    if (   $todo eq 'save'
2584        || $todo eq 'update'
2585        || $todo eq 'delete'
2586        || $todo eq 'add' )
2587    {
2588        fopen( MEMBINFO, ">$memberdir/memberinfo.txt" );
2589        print {MEMBINFO} map { "$_\t$memberinf{$_}\n" } keys %memberinf
2590          or croak "$croak{'print'} MEMBINFO";
2591        fclose(MEMBINFO);
2592        undef %memberinf;
2593    }
2594    return;
2595}
2596
2597sub Collapse_Load {
2598    my ( %userhide, $catperms, $catallowcol, $access );
2599    my $i = 0;
2600    map { $userhide{$_} = 1; } split /,/xsm, ${ $uid . $username }{'cathide'};
2601    foreach my $key (@categoryorder) {
2602        ( undef, $catperms, $catallowcol ) = split /\|/xsm, $catinfo{$key};
2603        $access = CatAccess($catperms);
2604        if ( $catallowcol == 1 && $access ) { $i++; }
2605        $catcol{$key} = 1;
2606        if ( $catallowcol == 1 && $userhide{$key} ) { $catcol{$key} = 0; }
2607    }
2608    $colbutton = ( $i == keys %userhide ) ? 0 : 1;
2609    $colloaded = 1;
2610    return;
2611}
2612
2613sub MailList {
2614    my ($m_line) = @_;
2615    is_admin_or_gmod();
2616    my $delmailline = q{};
2617    if ( !$INFO{'delmail'} ) {
2618        $mailline = $m_line;
2619        $mailline =~ s/\r//gxsm;
2620        $mailline =~ s/\n/<br \/>/gsm;
2621    }
2622    else {
2623        $delmailline = $INFO{'delmail'};
2624    }
2625    if ( -e ("$vardir/maillist.dat") ) {
2626        fopen( FILE, "$vardir/maillist.dat" );
2627        @maillist = <FILE>;
2628        fclose(FILE);
2629        fopen( FILE, ">$vardir/maillist.dat" );
2630        if ( !$INFO{'delmail'} ) {
2631            print {FILE} "$mailline\n" or croak "$croak{'print'} FILE";
2632        }
2633        foreach my $curmail (@maillist) {
2634            chomp $curmail;
2635            $otime = ( split /\|/xsm, $curmail )[0];
2636            if ( $otime ne $delmailline ) {
2637                print {FILE} "$curmail\n" or croak "$croak{'print'} FILE";
2638            }
2639        }
2640        fclose(FILE);
2641    }
2642    else {
2643        fopen( FILE, ">$vardir/maillist.dat" );
2644        print {FILE} "$mailline\n" or croak "$croak{'print'} FILE";
2645        fclose(FILE);
2646    }
2647    if ( $INFO{'delmail'} ) {
2648        $yySetLocation = qq~$adminurl?action=mailing~;
2649        redirectexit();
2650    }
2651    return;
2652}
2653
2654sub cloak {
2655    my ($input) = @_;
2656    my ( $user, $ascii, $key, $hex, $hexkey );
2657    $key = substr $date, length($date) - 2, 2;
2658    $hexkey = uc( unpack 'H2', pack 'V', $key );
2659    for my $n ( 0 .. ( length($input) - 1 ) ) {
2660        $ascii = substr $input, $n, 1;
2661        $ascii = ord($ascii) ^ $key;
2662
2663        # xor it instead of adding to prevent wide characters
2664        $hex = uc( unpack 'H2', pack 'V', $ascii );
2665        $user .= $hex;
2666    }
2667    $user .= $hexkey;
2668    $user .= '0';
2669    return $user;
2670}
2671
2672sub decloak {
2673    my ($input) = @_;
2674    my ( $user, $ascii, $key, $dec, $hexkey );
2675    if ( $input !~ /\A[0-9A-F]+\Z/xsm ) {
2676        return $input;
2677    }    # probably a non cloaked ID as it contains non hex code
2678    else { $input =~ s/0$//xsm; }
2679    $hexkey = substr $input, length($input) - 2, 2;
2680    $key = hex $hexkey;
2681    foreach my $n ( 0 .. ( length($input) - 3 ) ) {
2682        if ( $n % 2 == 0 ) {
2683            $dec = substr $input, $n, 2;
2684            $ascii = hex($dec) ^ $key;
2685
2686            # xor it to reverse it
2687            $ascii = chr $ascii;
2688            $user .= $ascii;
2689        }
2690    }
2691    return $user;
2692}
2693
2694# run through the log.txt and return the online/offline/away string near by the username
2695my %users_online;
2696
2697sub userOnLineStatus {
2698    my ($userToCheck) = @_;
2699
2700    if ( $userToCheck eq 'Guest' ) { return; }
2701    if ( exists $users_online{$userToCheck} ) {
2702        if ( $users_online{$userToCheck} ) {
2703            return $users_online{$userToCheck};
2704        }
2705    }
2706    else {
2707        map { $users_online{ ( split /\|/xsm, $_, 2 )[0] } = 0 } @logentries;
2708    }
2709
2710    LoadUser($userToCheck);
2711
2712    if ( exists $users_online{$userToCheck}
2713        && ( !${ $uid . $userToCheck }{'stealth'} || $iamadmin || $iamgmod ) )
2714    {
2715        ${ $uid . $userToCheck }{'offlinestatus'} = 'online';
2716        $users_online{$userToCheck} =
2717          qq~<span class="useronline">$maintxt{'60'}</span>~
2718          . ( ${ $uid . $userToCheck }{'stealth'} ? q{*} : q{} );
2719    }
2720    else {
2721        $users_online{$userToCheck} =
2722          qq~<span class="useroffline">$maintxt{'61'}</span>~;
2723    }
2724
2725# enable 'away' indicator $enable_MCaway: 0=Off; 1=Staff to Staff; 2=Staff to all; 3=Members
2726    if (  !$iamguest
2727        && $enable_MCstatusStealth
2728        && ( ( $enable_MCaway == 1 && $staff ) || $enable_MCaway > 1 )
2729        && ${ $uid . $userToCheck }{'offlinestatus'} eq 'away' )
2730    {
2731        $users_online{$userToCheck} =
2732          qq~<span class="useraway">$maintxt{'away'}</span>~;
2733    }
2734    return $users_online{$userToCheck};
2735}
2736
2737## moved from Register.pm so we can use for guest browsing
2738sub guestLangSel {
2739    opendir DIR, $langdir;
2740    $morelang = 0;
2741    my @langDir = readdir DIR;
2742    closedir DIR;
2743    foreach my $langitems ( sort { lc($a) cmp lc $b } @langDir ) {
2744        chomp $langitems;
2745        if (   ( $langitems ne q{.} )
2746            && ( $langitems ne q{..} )
2747            && ( $langitems ne q{.htaccess} )
2748            && ( $langitems ne q{index.html} ) )
2749        {
2750            $lngsel = q{};
2751            if ( $langitems eq $language ) {
2752                $lngsel = q~ selected="selected"~;
2753            }
2754            my $displang = $langitems;
2755            $displang =~ s/(.+?)\_(.+?)$/$1 ($2)/gism;
2756            $langopt .=
2757              qq~<option value="$langitems"$lngsel>$displang</option>~;
2758            $morelang++;
2759        }
2760    }
2761    return $langopt;
2762}
2763
2764##  control guest language selection.
2765
2766sub setGuestLang {
2767    ## if either 'no guest access' or 'no guest lan sel', throw the user back to the login screen
2768    if ( !$guestaccess || !$enable_guestlanguage ) {
2769        $yySetLocation = qq~$scripturl?action=login~;
2770        redirectexit();
2771    }
2772
2773  # otherwise, grab the selected language from the form and redirect to load it.
2774    $guestLang     = $FORM{'guestlang'};
2775    $language      = $guestLang;
2776    $yySetLocation = qq~$scripturl~;
2777    redirectexit();
2778    return;
2779}
2780
2781##  check for locked post bypass status - user must be at least mod and bypass lock must be set right.
2782sub checkUserLockBypass {
2783    if (
2784        $staff
2785        && (
2786               ( $bypass_lock_perm eq 'fa' && $iamadmin )
2787            || ( $bypass_lock_perm eq 'gmod' && ( $iamadmin || $iamgmod ) )
2788            || ( $bypass_lock_perm eq 'fmod'
2789                && ( $iamadmin || $iamgmod || $iamfmod ) )
2790            || $bypass_lock_perm eq 'mod'
2791        )
2792      )
2793    {
2794        return 1;
2795    }
2796}
2797
2798sub alertbox {
2799    my ($alert) = @_;
2800    $yymain .= qq~
2801<script type="text/javascript">
2802        alert("$alert");
2803</script>~;
2804    return;
2805}
2806
2807## load buddy list for user, new version from sub isUserBuddy
2808sub loadMyBuddy {
2809    %mybuddie = ();
2810    if ( ${ $uid . $username }{'buddylist'} ) {
2811        my @buddies = split /\|/xsm, ${ $uid . $username }{'buddylist'};
2812        chomp @buddies;
2813        foreach my $buddy (@buddies) {
2814            $buddy =~ s/^ //sm;
2815            $mybuddie{$buddy} = 1;
2816        }
2817    }
2818    return;
2819}
2820
2821## add user to buddy list
2822## this is only for the
2823sub addBuddy {
2824    my $newBuddy;
2825    if ( $INFO{'name'} ) {
2826        if   ($do_scramble_id) { $newBuddy = decloak( $INFO{'name'} ); }
2827        else                   { $newBuddy = $INFO{'name'}; }
2828        chomp $newBuddy;
2829        if ( $newBuddy eq $username ) { fatal_error('self_buddy'); }
2830        ToHTML($newBuddy);
2831        if ( !${ $uid . $username }{'buddylist'} ) {
2832            ${ $uid . $username }{'buddylist'} = "$newBuddy";
2833        }
2834        else {
2835            my @currentBuddies =
2836              split /\|/xsm, ${ $uid . $username }{'buddylist'};
2837            push @currentBuddies, $newBuddy;
2838            @currentBuddies = sort @currentBuddies;
2839            @newBuddies     = undupe(@currentBuddies);
2840            $newBuddyList   = join q{|}, @newBuddies;
2841            ${ $uid . $username }{'buddylist'} = $newBuddyList;
2842        }
2843        UserAccount( $username, 'update' );
2844    }
2845    $yySetLocation =
2846      qq~$scripturl?num=$INFO{'num'}/$INFO{'vpost'}#$INFO{'vpost'}~;
2847    if ( $INFO{'vpost'} eq q{} ) {
2848        $yySetLocation =
2849          qq~$scripturl?action=viewprofile;username=$INFO{'name'}~;
2850    }
2851    redirectexit();
2852    return;
2853}
2854
2855## check to see if user can view a broadcast message based on group
2856sub BroadMessageView {
2857    my ($imp) = @_;
2858    if ($iamadmin) { return 1; }
2859    if ($imp) {
2860        foreach my $checkgroup ( split /\,/xsm, $imp ) {
2861            if ( $checkgroup eq 'all' ) { return 1; }
2862            if (
2863                (
2864                       $checkgroup eq 'gmods'
2865                    || $checkgroup eq 'fmods'
2866                    || $checkgroup eq 'mods'
2867                )
2868                && $iamgmod
2869              )
2870            {
2871                return 1;
2872            }
2873            if ( ( $checkgroup eq 'fmods' || $checkgroup eq 'mods' )
2874                && $iamfmod )
2875            {
2876                return 1;
2877            }
2878            if ( $checkgroup eq 'mods' && $iammod ) { return 1; }
2879            if ( $checkgroup eq ${ $uid . $username }{'position'} ) {
2880                return 1;
2881            }
2882            foreach ( split /,/xsm, ${ $uid . $username }{'addgroups'} ) {
2883                if ( $checkgroup eq $_ ) { return 1; }
2884            }
2885        }
2886    }
2887    return 0;
2888}
2889
2890sub CheckUserPM_Level {
2891    my ($checkuser) = @_;
2892    return if $PM_level <= 1 || $UserPM_Level{$checkuser};
2893    $UserPM_Level{$checkuser} = 1;
2894    if ( !${ $uid . $checkuser }{'password'} ) { LoadUser($checkuser); }
2895    if ( ${ $uid . $checkuser }{'position'} eq 'Mid Moderator' ) {
2896        $UserPM_Level{$checkuser} = 4;
2897    }
2898    elsif (${ $uid . $checkuser }{'position'} eq 'Administrator'
2899        || ${ $uid . $checkuser }{'position'} eq 'Global Moderator' )
2900    {
2901        $UserPM_Level{$checkuser} = 3;
2902    }
2903    else {
2904      USERCHECK: foreach my $catid (@categoryorder) {
2905            foreach my $checkboard ( split /,/xsm, $cat{$catid} ) {
2906                foreach
2907                  my $curuser ( split /, ?/sm, ${ $uid . $checkboard }{'mods'} )
2908                {
2909                    if ( $checkuser eq $curuser ) {
2910                        $UserPM_Level{$checkuser} = 2;
2911                        last USERCHECK;
2912                    }
2913                }
2914                foreach my $curgroup ( split /, /sm,
2915                    ${ $uid . $checkboard }{'modgroups'} )
2916                {
2917                    if ( ${ $uid . $checkuser }{'position'} eq $curgroup ) {
2918                        $UserPM_Level{$checkuser} = 2;
2919                        last USERCHECK;
2920                    }
2921                    foreach ( split /,/xsm,
2922                        ${ $uid . $checkuser }{'addgroups'} )
2923                    {
2924                        if ( $_ eq $curgroup ) {
2925                            $UserPM_Level{$checkuser} = 2;
2926                            last USERCHECK;
2927                        }
2928                    }
2929                }
2930            }
2931        }
2932    }
2933    return;
2934}
2935
2936sub get_forum_master {
2937    if ( $mloaded != 1 ) {
2938        require "$boardsdir/forum.master";
2939    }
2940    return;
2941}
2942
2943sub get_micon {
2944    if ( -e ("$templatesdir/$usestyle/Micon.def") ) {
2945        $Micon_def = qq~$templatesdir/$usestyle/Micon.def~;
2946    }
2947    else { $Micon_def = qq~$templatesdir/default/Micon.def~; }
2948    require "$Micon_def";
2949    return;
2950}
2951
2952sub get_template {
2953    my ($templt) = @_;
2954    my @templ_list = ( $useboard, $usemessage, $usedisplay, $usemycenter );
2955    my @ld_list    = qw(BoardIndex MessageIndex Display MyCenter);
2956    my $ld_cn      = 0;
2957    for my $x ( 0 .. ( @ld_list - 1 ) ) {
2958        if ( $templt eq $ld_list[$x] ) {
2959            require qq~$templatesdir/$templ_list[$x]/$ld_list[$x].template~;
2960            $ld_cn = 1;
2961        }
2962    }
2963    if ( $ld_cn == 0 ) {
2964        if ( -e ("$templatesdir/$usestyle/$templt.template") ) {
2965            require "$templatesdir/$usestyle/$templt.template";
2966        }
2967        else {
2968            require "$templatesdir/default/$templt.template";
2969        }
2970    }
2971    return;
2972}
2973
2974sub get_gmod {
2975    if ( $iamgmod && -e "$vardir/gmodsettings.txt" ) {
2976        require "$vardir/gmodsettings.txt";
2977    }
2978    return;
2979}
2980
2981sub enable_yabbc {
2982    if ( $yyYaBBCloaded != 1 ) {
2983        require Sources::YaBBC;
2984    }
2985    return;
2986}
2987## moved from YaBBC.pm and Printpage.pl DAR 2/7/2012 ##
2988sub format_url {
2989    my ( $txtfirst, $txturl ) = @_;
2990    my $lasttxt = q{};
2991    if ( $txturl =~
2992m{(.*?)(\.|\.\)|\)\.|\!|\!\)|\)\!|\,|\)\,|\)|\;|\&quot\;|\&quot\;\.|\.\&quot\;|\&quot\;\,|\,\&quot\;|\&quot\;\;|\<\/)\Z}sm
2993      )
2994    {
2995        $txturl  = $1;
2996        $lasttxt = $2;
2997    }
2998    my $realurl = $txturl;
2999    $txturl =~ s/(\[highlight\]|\[\/highlight\]|\[edit\]|\[\/edit\])//igsm;
3000    $txturl =~ s/\[/&#91;/gsm;
3001    $txturl =~ s/\]/&#93;/gsm;
3002    $txturl =~ s/\<.+?\>//igsm;
3003    my $formaturl = qq~$txtfirst\[url\=$txturl\]$realurl\[\/url\]$lasttxt~;
3004    return $formaturl;
3005}
3006
3007sub format_url2 {
3008    my ( $txturl, $txtlink ) = @_;
3009    $txturl =~ s/(\[highlight\]|\[\/highlight\]|\[edit\]|\[\/edit\])//igsm;
3010    $txturl =~ s/\<.+?\>//igsm;
3011    my $formaturl = qq~[url=$txturl]$txtlink\[/url]~;
3012    return $formaturl;
3013}
3014
3015sub format_url3 {
3016    my ($txturl) = @_;
3017    my $txtlink = $txturl;
3018    $txturl =~ s/(\[highlight\]|\[\/highlight\]|\[edit\]|\[\/edit\])//igsm;
3019    $txturl =~ s/\[/&#91;/gsm;
3020    $txturl =~ s/\]/&#93;/gsm;
3021    $txturl =~ s/\<.+?\>//igsm;
3022    my $formaturl = qq~\[url\=$txturl\]$txtlink\[\/url\]~;
3023    return $formaturl;
3024}
3025
3026sub sizefont {
3027    ## limit minimum and maximum font pitch as CSS does not restrict it at all. ##
3028    my ( $tsize, $ttext ) = @_;
3029    if    ( !$fontsizemax )         { $fontsizemax = 72; }
3030    if    ( !$fontsizemin )         { $fontsizemin = 6; }
3031    if    ( $tsize < $fontsizemin ) { $tsize       = $fontsizemin; }
3032    elsif ( $tsize > $fontsizemax ) { $tsize       = $fontsizemax; }
3033    return qq~<span style="font-size: $tsize\pt;">$ttext</span><!--size-->~;
3034}
3035
3036sub regex_1 {
3037    my ($message) = @_;
3038    $message =~ s/[\r\n\ ]//gsm;
3039    $message =~ s/\&nbsp;//gxsm;
3040    $message =~ s/\[table\].*?\[tr\].*?\[td\]//gxsm;
3041    $message =~ s/\[\/td\].*?\[\/tr\].*?\[\/table\]//gxsm;
3042    $message =~ s/\[.*?\]//gxsm;
3043
3044    return $message;
3045}
3046
3047sub regex_2 {
3048    my ($message) = @_;
3049    $message =~ s/\cM//gsm;
3050    $message =~ s/\[([^\]\[]{0,30})\n([^\]\[]{0,30})\]/\[$1$2\]/gsm;
3051    $message =~ s/\[\/([^\]\[]{0,30})\n([^\]\[]{0,30})\]/\[\/$1$2\]/gsm;
3052    return $message;
3053}
3054
3055sub regex_3 {
3056    my ($message) = @_;
3057    $message =~ s/\t/ \&nbsp; \&nbsp; \&nbsp;/gsm;
3058    $message =~ s/\n/<br \/>/gsm;
3059    $message =~ s/([\000-\x09\x0b\x0c\x0e-\x1f\x7f])/\x0d/gxsm;
3060    return $message;
3061}
3062
3063sub regex_4 {
3064    my ($message) = @_;
3065    $message =~ s/\[b\](.*?)\[\/b\]/*$1*/igxsm;
3066    $message =~ s/\[i\](.*?)\[\/i\]/\/$1\//igxsm;
3067    $message =~ s/\[u\](.*?)\[\/u\]/_$1_/igxsm;
3068    $message =~ s/\[.*?\]//gxsm;
3069    $message =~ s/<br.*?>/\n/igxsm;
3070    return $message;
3071}
3072
3073sub password_check {
3074    LoadLanguage('Register');
3075
3076    if ( $action eq 'myprofile' ) {
3077        get_template('MyProfile');
3078    }
3079    else { $class = 'windowbg2'; }
3080    $check_js = qq~    <script type="text/javascript">
3081                // Password_strength_meter start
3082                var verdects = new Array("$pwstrengthmeter_txt{'1'}","$pwstrengthmeter_txt{'2'}","$pwstrengthmeter_txt{'3'}","$pwstrengthmeter_txt{'4'}","$pwstrengthmeter_txt{'5'}","$pwstrengthmeter_txt{'6'}","$pwstrengthmeter_txt{'7'}","$pwstrengthmeter_txt{'8'}");
3083                var colors = new Array("#8F8F8F","#BF0000","#FF0000","#00A0FF","#33EE00","#339900");
3084                var scores = new Array($pwstrengthmeter_scores);
3085                var common = new Array($pwstrengthmeter_common);
3086                var minchar = $pwstrengthmeter_minchar;
3087
3088                function runPassword(D) {
3089                    var nPerc = checkPassword(D);
3090                    if (nPerc > -199 && nPerc < 0) {
3091                        strColor = colors[0];
3092                        strText = verdects[1];
3093                        strWidth = "5%";
3094                    } else if (nPerc == -200) {
3095                        strColor = colors[1];
3096                        strText = verdects[0];
3097                        strWidth = "0%";
3098                    } else if (scores[0] == -1 && scores[1] == -1 && scores[2] == -1 && scores[3] == -1) {
3099                        strColor = colors[4];
3100                        strText = verdects[7];
3101                        strWidth = "100%";
3102                    } else if (nPerc <= scores[0]) {
3103                        strColor = colors[1];
3104                        strText = verdects[2];
3105                        strWidth = "10%";
3106                    } else if (nPerc > scores[0] && nPerc <= scores[1]) {
3107                        strColor = colors[2];
3108                        strText = verdects[3];
3109                        strWidth = "25%";
3110                    } else if (nPerc > scores[1] && nPerc <= scores[2]) {
3111                        strColor = colors[3];
3112                        strText = verdects[4];
3113                        strWidth = "50%";
3114                    } else if (nPerc > scores[2] && nPerc <= scores[3]) {
3115                        strColor = colors[4];
3116                        strText = verdects[5];
3117                        strWidth = "75%";
3118                    } else {
3119                        strColor = colors[5];
3120                        strText = verdects[6];
3121                        strWidth = "100%";
3122                    }
3123                    document.getElementById("passwrd1_bar").style.width = strWidth;
3124                    document.getElementById("passwrd1_bar").style.backgroundColor = strColor;
3125                    document.getElementById("passwrd1_text").style.color = strColor;
3126                    document.getElementById("passwrd1_text").childNodes[0].nodeValue = strText;
3127                }
3128
3129                function checkPassword(C) {
3130                    if (C.length === 0 || C.length < minchar) return -100;
3131
3132                    for (var D = 0; D < common.length; D++) {
3133                        if (C.toLowerCase() == common[D]) return -200;
3134                    }
3135
3136                    var F = 0;
3137                    if (C.length >= minchar && C.length <= (minchar+2)) {
3138                        F = (F + 6);
3139                    } else if (C.length >= (minchar + 3) && C.length <= (minchar + 4)) {
3140                        F = (F + 12);
3141                    } else if (C.length >= (minchar + 5)) {
3142                        F = (F + 18);
3143                    }
3144
3145                    if (C.match(/[a-z]/)) {
3146                        F = (F + 1);
3147                    }
3148                    if (C.match(/[A-Z]/)) {
3149                        F = (F + 5);
3150                    }
3151                    if (C.match(/d+/)) {
3152                        F = (F + 5);
3153                    }
3154                    if (C.match(/(.*[0-9].*[0-9].*[0-9])/)) {
3155                        F = (F + 7);
3156                    }
3157                    if (C.match(/.[!,\@,#,\$,\%,^,&,*,?,_,\~]/)) {
3158                        F = (F + 5);
3159                    }
3160                    if (C.match(/(.*[!,\@,#,\$,\%,^,&,*,?,_,\~].*[!,\@,#,\$,\%,^,&,*,?,_,\~])/)) {
3161                        F = (F + 7);
3162                    }
3163                    if (C.match(/([a-z].*[A-Z])|([A-Z].*[a-z])/)){
3164                        F = (F + 2);
3165                    }
3166                    if (C.match(/([a-zA-Z])/) && C.match(/([0-9])/)) {
3167                        F = (F + 3);
3168                    }
3169                    if (C.match(/([a-zA-Z0-9].*[!,\@,#,\$,\%,^,&,*,?,_,\~])|([!,\@,#,\$,\%,^,&,*,?,_,\~].*[a-zA-Z0-9])/)) {
3170                        F = (F + 3);
3171                    }
3172                    return F;
3173                }
3174                // Password_strength_meter end
3175                        </script>~;
3176    $check = $show_check;
3177    $check .= $show_check_bot;
3178    $check =~ s/{yabb check_js}/$check_js/sm;
3179    $check =~ s/{yabb tmpregpasswrd1}/$tmpregpasswrd1/sm;
3180    $check =~ s/{yabb tmpregpasswrd2}/$tmpregpasswrd2/sm;
3181
3182    return $check;
3183}
3184
3185sub BoardPassw {
3186#    my ($boardname,$viewnum,$currentboard) = @_;
3187    #template in MessageIndex.template
3188    $yymain .= $boardpassw;
3189
3190    $yytitle = qq~$maintxt{'900pw'}: $boardname~;
3191    template();
3192    exit;
3193}
3194
3195sub BoardPassw_g {
3196    #template in MessageIndex.template
3197    $yymain .= $boardpassw_g;
3198
3199    $yytitle = qq~$maintxt{'900pw'}: $boardname~;
3200    template();
3201    exit;
3202}
3203sub BoardPasswCheck {
3204
3205    my $returnnum   = $FORM{'pswviewnum'};
3206    my $returnboard = $FORM{'pswcurboard'};
3207    my $spass       = ${ $uid . $returnboard }{'brdpassw'};
3208    my $cryptpass   = encode_password("$FORM{'boardpw'}");
3209    if ( $FORM{'boardpw'} eq q{} ) { fatal_error('', "$maintxt{'900pe'}"); }
3210    if ( $spass ne $cryptpass ) { fatal_error('wrong_pass'); }
3211    $ck{'len'} = 'Sunday, 17-Jan-2030 00:00:00 GMT';
3212    my $cookiename = "$cookiepassword$returnboard$username";
3213    push @otherCookies,
3214      write_cookie(
3215        -name    => "$cookiename",
3216        -value   => "$cryptpass",
3217        -path    => q{/},
3218        -expires => "$ck{'len'}"
3219      );
3220    WriteLog();
3221    undef $FORM{'boardpw'};
3222
3223    if ( $returnnum ne q{} ) {
3224        $yySetLocation = qq~$scripturl?num=$returnnum~;
3225    }
3226    else {
3227        $yySetLocation = qq~$scripturl?board=$returnboard~;
3228    }
3229    redirectexit();
3230    return;
3231}
3232
3233sub UploadFile {
3234    my ( $file_upload, $file_directory, $file_extensions, $file_size, $directory_limit ) = @_;
3235    $file_directory = qq~$htmldir/$file_directory~;
3236
3237    LoadLanguage('FA');
3238    require Sources::SpamCheck;
3239
3240    if ($CGI_query) { $file = $CGI_query->upload("$file_upload"); }
3241    if ($file) {
3242        $fixfile = $file;
3243        $fixfile =~ s/.+\\([^\\]+)$|.+\/([^\/]+)$/$1/xsm;
3244        if ( $fixfile =~ /[^0-9A-Za-z\+\-\.:_]/xsm )
3245       {    # replace all inappropriate characters
3246            # Transliteration
3247            my @ISO_8859_1 =
3248              qw(A B V G D E JO ZH Z I J K L M N O P R S T U F H C CH SH SHH _ Y _ JE JU JA a b v g d e jo zh z i j k l m n o p r s t u f h c ch sh shh _ y _ je ju ja);
3249            my $x = 0;
3250            foreach (
3251              qw(À Á Â Ã Ä Å ¨ Æ Ç È É Ê Ë Ì Í Î Ï Ð Ñ Ò Ó Ô Õ Ö × Ø Ù Ú Û Ü Ý Þ ß à á â ã ä å ¸ æ ç è é ê ë ì í î ï ð ñ ò ó ô õ ö ÷ ø ù ú û ü ý þ ÿ)
3252            )
3253            {
3254            $fixfile =~ s/$_/$ISO_8859_1[$x]/igxsm;
3255            $x++;
3256            }
3257
3258            # END Transliteration. Thanks to "Velocity" for this contribution.
3259            $fixfile =~ s/[^0-9A-Za-z\+\-\.:_]/_/gxsm;
3260        }
3261
3262        # replace . with _ in the filename except for the extension
3263        my $fixname = $fixfile;
3264        if ( $fixname =~ s/(.+)(\..+?)$/$1/xsm ) {
3265            $fixext = $2;
3266        }
3267
3268        $spamdetected = spamcheck("$fixname");
3269        if ( !$staff ) {
3270            if ( $spamdetected == 1 ) {
3271                ${ $uid . $username }{'spamcount'}++;
3272                ${ $uid . $username }{'spamtime'} = $date;
3273                UserAccount( $username, 'update' );
3274                $spam_hits_left_count = $post_speed_count -
3275                  ${ $uid . $username }{'spamcount'};
3276                unlink "$file_directory/$fixfile";
3277                fatal_error('tsc_alert');
3278            }
3279        }
3280        if ( $use_guardian && $string_on ) {
3281            @bannedstrings = split /\|/xsm, $banned_strings;
3282            foreach (@bannedstrings) {
3283                chomp $_;
3284                if ( $fixname =~ m/$_/ism ) {
3285                    fatal_error( 'attach_name_blocked', "($_)" );
3286                }
3287            }
3288        }
3289
3290        $fixext  =~ s/\.(pl|pm|cgi|php)/._$1/ixsm;
3291        $fixname =~ s/\.(?!tar$)/_/gxsm;
3292        $fixfile = qq~$fixname$fixext~;
3293        if ( $fixfile eq 'index.html' || $fixfile eq '.htaccess' ) { fatal_error('attach_file_blocked') };
3294
3295        $fixfile = check_existence( $file_directory, $fixfile );
3296
3297        my $match = 0;
3298        foreach my $ext ( split / /, $file_extensions ) {
3299            if ( grep { /$ext$/ixsm } $fixfile ) {
3300                $match = 1;
3301                last;
3302            }
3303        }
3304
3305        if (!$match) {
3306            unlink "$file_directory/$fixfile";
3307            fatal_error( q{}, "$fixfile $fatxt{'20'} $file_extensions" );
3308        }
3309
3310        my ( $size, $buffer, $filesize, $file_buffer );
3311        while ( $size = read $file, $buffer, 512 ) {
3312            $filesize += $size;
3313            $file_buffer .= $buffer;
3314        }
3315        if ( $file_size && $filesize > ( 1024 * $file_size ) ) {
3316            unlink "$file_directory/$fixfile";
3317            fatal_error( q{},
3318                    "$fatxt{'21'} $fixfile ("
3319                  . int( $filesize / 1024 )
3320                  . " KB) $fatxt{'21b'} "
3321                  . $file_size );
3322        }
3323        if ($directory_limit) {
3324            my $dirsize = dirsize($file_directory);
3325            if ( $file_size > ( ( 1024 * $directory_limit ) - $dirsize ) ) {
3326                unlink "$file_directory/$fixfile";
3327                fatal_error(
3328                    q{},
3329                    "$fatxt{'22'} $fixfile ("
3330                      . (
3331                        int( $file_size / 1024 ) -
3332                          $directory_limit +
3333                          int( $dirsize / 1024 )
3334                       )
3335                       . " KB) $fatxt{'22b'}"
3336                );
3337            }
3338        }
3339
3340        # create a new file on the server using the formatted ( new instance ) filename
3341        if ( fopen( NEWFILE, ">$file_directory/$fixfile" ) ) {
3342            binmode NEWFILE;
3343
3344            # needed for operating systems (OS) Windows, ignored by Linux
3345            print {NEWFILE} $file_buffer
3346              or croak "$croak{'print'} NEWFILE"; # write new file on HD
3347            fclose(NEWFILE);
3348        }
3349        else
3350        { # return the server's error message if the new file could not be created
3351                unlink "$file_directory/$fixfile";
3352                fatal_error( 'file_not_open', "$file_directory" );
3353        }
3354
3355        # check if file has actually been uploaded, by checking the file has a size
3356        $filesizekb{$fixfile} = -s "$file_directory/$fixfile";
3357        if ( !$filesizekb{$fixfile} ) {
3358            unlink "$file_directory/$fixfile";
3359            fatal_error( 'file_not_uploaded', $fixfile );
3360        }
3361        $filesizekb{$fixfile} = int( $filesizekb{$fixfile} / 1024 );
3362
3363        if ( $fixfile =~ /\.(jpg|gif|png|jpeg)$/ism ) {
3364            my $okatt = 1;
3365            if ( $fixfile =~ /gif$/ism ) {
3366                my $header;
3367                fopen( ATTFILE, "$file_directory/$fixfile" );
3368                read ATTFILE, $header, 10;
3369                my $giftest;
3370                ( $giftest, undef, undef, undef, undef, undef ) =
3371                  unpack 'a3a3C4', $header;
3372                fclose(ATTFILE);
3373                if ( $giftest ne 'GIF' ) { $okatt = 0; }
3374            }
3375            fopen( ATTFILE, "$file_directory/$fixfile" );
3376            while ( read ATTFILE, $buffer, 1024 ) {
3377                if ( $buffer =~ /<(html|script|body)/igxsm ) {
3378                    $okatt = 0;
3379                    last;
3380                }
3381            }
3382            fclose(ATTFILE);
3383            if ( !$okatt )
3384            {    # delete the file as it contains illegal code
3385                unlink "$file_directory/$fixfile";
3386                fatal_error( 'file_not_uploaded', "$fixfile $fatxt{'20a'}" );
3387             }
3388        }
3389
3390    }
3391    return ($fixfile);
3392}
3393
3394sub isempty {
3395    my ($x, $y) = @_;
3396    if ( defined $x && $x ne q{} ) {
3397        $y = $x;
3398    }
3399    return $y;
3400}
3401
34021;
3403