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> $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~ <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/\'/'/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/\'/'/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 = ' '; 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/;/&/g; $x; } 733 # End of workaround 734 735 if ( !$copyright ) { 736 $output = 737q~<h1 class="center"><b>Sorry, the copyright tag {yabb copyright} must be in the template.<br />Please notify this forum'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'}->]$name=@value\[<-$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'}->]$name=$value\[<-$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">»» $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"> ~ 1367 . ( ' ' x $indent ) 1368 . ( $dash x ( $indent / 2 ) ) 1369 . qq~ $boardname ««</option>\n~ 1370 : qq~ <option selected="selected" value="board=$board" class="forumcurrentboard">»» $boardname</option>\n~; 1371 } 1372 elsif ( !${ $uid . $board }{'canpost'} && $subboard{$board} ) { 1373 $selecthtml .= 1374 qq~ <option value="boardselect=$board"> ~ 1375 . ( ' ' x $indent ) 1376 . ( $dash x ( $indent / 2 ) ) 1377 . qq~ $boardname</option>\n~; 1378 } 1379 else { 1380 $selecthtml .= 1381 qq~ <option value="board=$board"> ~ 1382 . ( ' ' 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/ / /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","mail\u0074o\u003a",'$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/&/&/gsm; 1691 $_[0] =~ s/\}/\}/gsm; 1692 $_[0] =~ s/\{/\{/gsm; 1693 $_[0] =~ s/\|/|/gsm; 1694 $_[0] =~ s/>/>/gsm; 1695 $_[0] =~ s/</</gsm; 1696 $_[0] =~ s/ / /gsm; 1697 $_[0] =~ s/ / /gsm; 1698 $_[0] =~ s/"/"/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/"/"/gsm; #" make my syntax checker happy; 1706 $_[0] =~ s/ / /gsm; 1707 $_[0] =~ s/</</gsm; 1708 $_[0] =~ s/>/>/gsm; 1709 $_[0] =~ s/|/\|/gsm; 1710 $_[0] =~ s/{/\{/gsm; 1711 $_[0] =~ s/}/\}/gsm; 1712 $_[0] =~ s/&/&/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/ /\[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\]/ /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;)/\&$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;)/\&$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{(.*?)(\.|\.\)|\)\.|\!|\!\)|\)\!|\,|\)\,|\)|\;|\"\;|\"\;\.|\.\"\;|\"\;\,|\,\"\;|\"\;\;|\<\/)\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/\[/[/gsm; 3001 $txturl =~ s/\]/]/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/\[/[/gsm; 3020 $txturl =~ s/\]/]/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/\ //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/ \ \ \ /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