1############################################################################### 2# System.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############################################################################### 15use CGI::Carp qw(fatalsToBrowser); 16our $VERSION = '2.6.11'; 17 18$systempmver = 'YaBB 2.6.11 $Revision: 1611 $'; 19 20sub BoardTotals { 21 my ( $job, @updateboards ) = @_; 22 my ( $line, @lines, $updateboard, @boardvars, $cnt ); 23 if ( !@updateboards ) { @updateboards = @allboards; } 24 chomp @updateboards; 25 if (@updateboards) { 26 my @tags = 27 qw(board threadcount messagecount lastposttime lastposter lastpostid lastreply lastsubject lasticon lasttopicstate); 28 if ( $job eq 'load' ) { 29 fopen( FORUMTOTALS, "$boardsdir/forum.totals" ) 30 or fatal_error( 'cannot_open', "$boardsdir/forum.totals", 1 ); 31 @lines = <FORUMTOTALS>; 32 fclose(FORUMTOTALS); 33 chomp @lines; 34 foreach $updateboard (@updateboards) { 35 foreach $line (@lines) { 36 @boardvars = split /\|/xsm, $line; 37 if ( $boardvars[0] eq $updateboard 38 && exists $board{ $boardvars[0] } ) 39 { 40 for my $cnt ( 1 .. $#tags ) { 41 ${ $uid . $updateboard }{ $tags[$cnt] } = 42 $boardvars[$cnt]; 43 } 44 last; 45 } 46 } 47 } 48 } 49 elsif ( $job eq 'update' ) { 50 fopen( FORUMTOTALS, "<$boardsdir/forum.totals" ) 51 or fatal_error( 'cannot_open', "$boardsdir/forum.totals", 1 ); 52 @lines = <FORUMTOTALS>; 53 fclose( FORUMTOTALS ); 54 for $line ( 0 .. ( $#lines ) ) { 55 @boardvars = split /\|/xsm, $lines[$line]; 56 if ( exists $board{ $boardvars[0] } ) { 57 if ( $boardvars[0] eq $updateboards[0] ) { 58 $lines[$line] = "$updateboards[0]|"; 59 chomp $boardvars[9]; 60 for my $cnt ( 1 .. $#tags ) { 61 if ( 62 exists( 63 ${ $uid . $boardvars[0] }{ $tags[$cnt] } 64 ) 65 ) 66 { 67 $lines[$line] .= 68 ${ $uid . $boardvars[0] }{ $tags[$cnt] }; 69 } 70 else { 71 $lines[$line] .= $boardvars[$cnt]; 72 } 73 $lines[$line] .= $cnt < $#tags ? q{|} : "\n"; 74 } 75 } 76 } 77 else { 78 $lines[$line] = q{}; 79 } 80 } 81 fopen( FORUMTOTALS, ">$boardsdir/forum.totals" ) 82 or fatal_error( 'cannot_open', "$boardsdir/forum.totals", 1 ); 83 print {FORUMTOTALS} @lines or croak "$croak{'print'} FORUMTOTALS"; 84 fclose(FORUMTOTALS); 85 86 } 87 elsif ( $job eq 'delete' ) { 88 fopen( FORUMTOTALS, "<$boardsdir/forum.totals" ) 89 or fatal_error( 'cannot_open', "$boardsdir/forum.totals", 1 ); 90 @lines = <FORUMTOTALS>; 91 fclose( FORUMTOTALS ); 92 for my $line ( 0 .. ( @lines - 1 ) ) { 93 @boardvars = split /\|/xsm, $lines[$line], 2; 94 if ( $boardvars[0] eq $updateboards[0] 95 || !exists $board{ $boardvars[0] } ) 96 { 97 $lines[$line] = q{}; 98 } 99 } 100 fopen( FORUMTOTALS, ">$boardsdir/forum.totals" ) 101 or fatal_error( 'cannot_open', "$boardsdir/forum.totals", 1 ); 102 print {FORUMTOTALS} @lines or croak "$croak{'print'} FORUMTOTALS"; 103 fclose(FORUMTOTALS); 104 } 105 elsif ( $job eq 'add' ) { 106 fopen( FORUMTOTALS, ">>$boardsdir/forum.totals" ) 107 or fatal_error( 'cannot_open', "$boardsdir/forum.totals", 1 ); 108 foreach (@updateboards) { 109 print {FORUMTOTALS} "$_|0|0|N/A|N/A||||\n" 110 or croak "$croak{'print'} FORUMTOTALS"; 111 } 112 fclose(FORUMTOTALS); 113 } 114 } 115 return; 116} 117 118sub BoardCountTotals { 119 my ($cntboard) = @_; 120 if ( !$cntboard ) { return; } 121 122 fopen( BOARD, "$boardsdir/$cntboard.txt" ) 123 or fatal_error( 'cannot_open', "$boardsdir/$cntboard.txt", 1 ); 124 my @threads = <BOARD>; 125 fclose(BOARD); 126 my $threadcount = @threads; 127 my $messagecount = $threadcount; 128 for my $i ( 0 .. ( @threads - 1 ) ) { 129 my @threadline = split /\|/xsm, $threads[$i]; 130 if ( $threadline[8] =~ /m/sm ) { 131 $threadcount--; 132 $messagecount--; 133 next; 134 } 135 $messagecount += $threadline[5]; 136 } 137 ${ $uid . $cntboard }{'threadcount'} = $threadcount; 138 ${ $uid . $cntboard }{'messagecount'} = $messagecount; 139 BoardSetLastInfo( $cntboard, \@threads ); 140 return; 141} 142 143sub BoardSetLastInfo { 144 my ( $setboard, $board_ref ) = @_; 145 my ( $lastthread, $lastthreadid, $lastthreadstate, @lastthreadmessages, 146 @lastmessage ); 147 148 foreach my $lastthread ( @{$board_ref} ) { 149 if ($lastthread) { 150 ( 151 $lastthreadid, undef, undef, 152 undef, undef, undef, 153 undef, undef, $lastthreadstate 154 ) = split /\|/xsm, $lastthread; 155 if ( $lastthreadstate !~ /m/sm ) { 156 chomp $lastthreadstate; 157 fopen( FILE, "$datadir/$lastthreadid.txt" ) 158 or fatal_error( 'cannot_open', "$datadir/$lastthreadid.txt", 159 1 ); 160 @lastthreadmessages = <FILE>; 161 fclose(FILE); 162 @lastmessage = 163 split /\|/xsm, $lastthreadmessages[-1], 7; 164 last; 165 } 166 $lastthreadid = q{}; 167 } 168 } 169 ${ $uid . $setboard }{'lastposttime'} = 170 $lastthreadid ? $lastmessage[3] : 'N/A'; 171 ${ $uid . $setboard }{'lastposter'} = 172 $lastthreadid 173 ? ( 174 $lastmessage[4] eq 'Guest' ? "Guest-$lastmessage[1]" : $lastmessage[4] ) 175 : 'N/A'; 176 ${ $uid . $setboard }{'lastpostid'} = $lastthreadid ? $lastthreadid : q{}; 177 ${ $uid . $setboard }{'lastreply'} = 178 $lastthreadid ? $#lastthreadmessages : q{}; 179 ${ $uid . $setboard }{'lastsubject'} = 180 $lastthreadid ? $lastmessage[0] : q{}; 181 ${ $uid . $setboard }{'lasticon'} = $lastthreadid ? $lastmessage[5] : q{}; 182 ${ $uid . $setboard }{'lasttopicstate'} = 183 ( $lastthreadid && $lastthreadstate ) ? $lastthreadstate : '0'; 184 BoardTotals( 'update', $setboard ); 185 return; 186} 187 188#### THREAD MANAGEMENT #### 189 190sub MessageTotals { 191 192 # usage: &MessageTotals("task",<threadid>) 193 # tasks: update, load, incview, incpost, decpost, recover 194 my ( $job, $updatethread ) = @_; 195 chomp $updatethread; 196 if ( !$updatethread ) { return; } 197 198 if ( $job eq 'update' ) { 199 if ( ${$updatethread}{'board'} eq q{} ) 200 { ## load if the variable is not already filled 201 MessageTotals( 'load', $updatethread ); 202 } 203 } 204 elsif ( $job eq 'load' ) { 205 if ( ${$updatethread}{'board'} ne q{} ) { 206 return; 207 } ## skip load if the variable is already filled 208 fopen( CTB, "$datadir/$updatethread.ctb", 1 ); 209 while ( my $inp = <CTB> ) { 210 if ( $inp =~ /^'(.*?)',"(.*?)"/xsm ) { ${$updatethread}{$1} = $2; } 211 } 212 fclose(CTB); 213 @repliers = split /,/xsm, ${$updatethread}{'repliers'}; 214 return; 215 216 } 217 elsif ( $job eq 'incview' ) { 218 ${$updatethread}{'views'}++; 219 220 } 221 elsif ( $job eq 'incpost' ) { 222 ${$updatethread}{'replies'}++; 223 224 } 225 elsif ( $job eq 'decpost' ) { 226 ${$updatethread}{'replies'}--; 227 228 } 229 elsif ( $job eq 'recover' ) { 230 231 # storing thread status 232 my $threadstatus; 233 my $openboard = ${$updatethread}{'board'}; 234 fopen( TESTBOARD, "$boardsdir/$openboard.txt" ) 235 or fatal_error( 'cannot_open', "$boardsdir/$openboard.txt", 1 ); 236 while ( $ThreadLine = <TESTBOARD> ) { 237 if ( $updatethread == ( split /\|/xsm, $ThreadLine, 2 )[0] ) { 238 $threadstatus = ( split /\|/xsm, $ThreadLine )[8]; 239 chomp $threadstatus; 240 last; 241 } 242 } 243 fclose(TESTBOARD); 244 245 # storing thread other info 246 fopen( MSG, "$datadir/$updatethread.txt" ) 247 or fatal_error( 'cannot_open', "$datadir/$updatethread.txt", 1 ); 248 my @threaddata = <MSG>; 249 fclose(MSG); 250 my @lastinfo = split /\|/xsm, $threaddata[-1]; 251 my $lastpostdate = sprintf '%010d', $lastinfo[3]; 252 my $lastposter = 253 $lastinfo[4] eq 'Guest' ? qq~Guest-$lastinfo[1]~ : $lastinfo[4]; 254 255 # rewrite/create a correct thread.ctb 256 ${$updatethread}{'replies'} = $#threaddata; 257 ${$updatethread}{'views'} = ${$updatethread}{'views'} || 0; 258 ${$updatethread}{'lastposter'} = $lastposter; 259 ${$updatethread}{'lastpostdate'} = $lastpostdate; 260 ${$updatethread}{'threadstatus'} = $threadstatus; 261 @repliers = (); 262 } 263 else { 264 return; 265 } 266 267 ## trap writing false ctb files on forged num= actions ## 268 if ( -e "$datadir/$updatethread.txt" ) { 269 my $format = 'SDT, DD MM YYYY HH:mm:ss zzz'; # The format 270 # Save their old format 271 my $timeformat = ${ $uid . $username }{'timeformat'}; 272 my $timeselect = ${ $uid . $username }{'timeselect'}; 273 274 # Override their settings 275 ${ $uid . $username }{'timeformat'} = $format; 276 ${ $uid . $username }{'timeselect'} = 7; 277 278 # Do the work 279 my $newtime = timeformat( $date, 1, 'rfc' ); 280 281 # And restore their settings 282 ${ $uid . $username }{'timeformat'} = $timeformat; 283 ${ $uid . $username }{'timeselect'} = $timeselect; 284 285 ${$updatethread}{'repliers'} = join q{,}, @repliers; 286 287# Changes here on @tag must also be done in Post.pm -> sub Post2 -> my @tag = ... 288 my @tag = 289 qw(board replies views lastposter lastpostdate threadstatus repliers); 290 fopen( UPDATE_CTB, ">$datadir/$updatethread.ctb", 1 ) 291 or fatal_error( 'cannot_open', "$datadir/$updatethread.ctb", 1 ); 292 print {UPDATE_CTB} 293 qq~### ThreadID: $updatethread, LastModified: $newtime ###\n\n~ 294 or croak "$croak{'print'} UPDATE_CTB"; 295 for my $cnt ( 0 .. ( @tag - 1 ) ) { 296 print {UPDATE_CTB} qq~'$tag[$cnt]',"${$updatethread}{$tag[$cnt]}"\n~ 297 or croak "$croak{'print'} UPDATE_CTB"; 298 } 299 fclose(UPDATE_CTB); 300 } 301 return; 302} 303 304#### USER AND MEMBERSHIP MANAGEMENT #### 305 306sub UserAccount { 307 my ( $user, $action, $pars ) = @_; 308 return if !${ $uid . $user }{'password'}; 309 310 if ( $action eq 'update' ) { 311 if ($pars) { 312 foreach ( split /\+/xsm, $pars ) { ${ $uid . $user }{$_} = $date; } 313 } 314 elsif ( $username eq $user ) { 315 ${ $uid . $user }{'lastonline'} = $date; 316 } 317 $userext = 'vars'; 318 if ( !exists( ${ $uid . $user }{'reversetopic'} ) ) { 319 ${ $uid . $user }{'reversetopic'} = $ttsreverse; 320 } 321 } 322 elsif ( $action eq 'preregister' ) { 323 $userext = 'pre'; 324 } 325 elsif ( $action eq 'register' ) { 326 $userext = 'vars'; 327 } 328 elsif ( $action eq 'delete' ) { 329 unlink "$memberdir/$user.vars"; 330 return; 331 } 332 else { $userext = 'vars'; } 333 334 # using sequential tag writing as hashes do not sort the way we like them to 335 my @tags = 336 qw(realname password position addgroups email hidemail regdate regtime regreason location bday hideage disableage gender disablegender userpic usertext signature template language stealth webtitle weburl icq aim yim skype myspace facebook twitter youtube msn gtalk timeselect user_tz dynamic_clock postcount lastonline lastpost lastim im_ignorelist im_popup im_imspop pmviewMess notify_me board_notifications thread_notifications favorites buddylist cathide pageindex reversetopic postlayout sesquest sesanswer session lastips onlinealert offlinestatus awaysubj awayreply awayreplysent spamcount spamtime hide_avatars hide_user_text hide_img hide_attach_img hide_signat hide_smilies_row numberformat collapsebdrules return_to); 337 338 if ($extendedprofiles) { 339 require Sources::ExtendedProfiles; 340 push @tags, ext_get_fields_array(); 341 } 342 push @tags, 'topicpreview', 'collapsescpoll'; 343 ## Mod hook ## 344 345 fopen( UPDATEUSER, ">$memberdir/$user.$userext", 1 ) 346 or fatal_error( 'cannot_open', "$memberdir/$user.$userext", 1 ); 347 print {UPDATEUSER} "### User variables for ID: $user ###\n\n" 348 or croak "$croak{'print'} UPDATEUSER"; 349 for my $cnt ( 0 .. ( @tags - 1 ) ) { 350 print {UPDATEUSER} qq~'$tags[$cnt]',"${$uid.$user}{$tags[$cnt]}"\n~ 351 or croak "$croak{'print'} UPDATEUSER"; 352 } 353 fclose(UPDATEUSER); 354 return; 355} 356 357sub MemberIndex { 358 my ( $memaction, $user, $mychk ) = @_; 359 if ( $memaction eq 'add' && LoadUser($user) ) { 360 $theregdate = stringtotime( ${ $uid . $user }{'regdate'} ); 361 $theregdate = sprintf '%010d', $theregdate; 362 if ( !${ $uid . $user }{'postcount'} ) { 363 ${ $uid . $user }{'postcount'} = 0; 364 } 365 if ( !${ $uid . $user }{'position'} ) { 366 ${ $uid . $user }{'position'} = 367 MemberPostGroup( ${ $uid . $user }{'postcount'} ); 368 } 369 ManageMemberlist( 'add', $user, $theregdate ); 370 ManageMemberinfo( 371 'add', 372 $user, 373 ${ $uid . $user }{'realname'}, 374 ${ $uid . $user }{'email'}, 375 ${ $uid . $user }{'position'}, 376 ${ $uid . $user }{'postcount'} 377 ); 378 379 fopen( TTL, "$memberdir/members.ttl" ) 380 or fatal_error( 'cannot_open', "$memberdir/members.ttl", 1 ); 381 $buffer = <TTL>; 382 fclose(TTL); 383 384 ( $membershiptotal, undef ) = split /\|/xsm, $buffer; 385 $membershiptotal++; 386 387 fopen( TTL, ">$memberdir/members.ttl" ) 388 or fatal_error( 'cannot_open', "$memberdir/members.ttl", 1 ); 389 print {TTL} qq~$membershiptotal|$user~ or croak "$croak{'print'} TTL"; 390 fclose(TTL); 391 return 0; 392 393 } 394 elsif ( $memaction eq 'remove' && $user ) { 395 ManageMemberlist( 'delete', $user ); 396 ManageMemberinfo( 'delete', $user ); 397 398 require Sources::Notify; 399 removeNotifications($user); 400 401 fopen( MEMLIST, "$memberdir/memberlist.txt" ) 402 or fatal_error( 'cannot_open', "$memberdir/memberlist.txt", 1 ); 403 @memberlt = <MEMLIST>; 404 fclose(MEMLIST); 405 406 my $membershiptotal = @memberlt; 407 my ( $lastuser, undef ) = split /\t/xsm, $memberlt[-1], 2; 408 409 fopen( TTL, ">$memberdir/members.ttl" ) 410 or fatal_error( 'cannot_open', "$memberdir/members.ttl", 1 ); 411 print {TTL} qq~$membershiptotal|$lastuser~ 412 or croak "$croak{'print'} TTL"; 413 fclose(TTL); 414 return 0; 415 416 } 417 elsif ( ( $memaction eq 'check_exist' || $memaction eq 'who_is' ) && $user ) { 418 ManageMemberinfo('load'); 419 while ( ( $curmemb, $value ) = each %memberinf ) { 420 ( $curname, $curmail, $curposition, $curpostcnt ) = 421 split /\|/xsm, $value; 422 if ( $memaction eq 'check_exist') { 423 if ( lc $user eq lc $curmemb && $mychk == 0 ) { 424 undef %memberinf; 425 return $curmemb; 426 } 427 elsif ( lc $user eq lc $curmail && $mychk == 2 ) { 428 undef %memberinf; 429 return $curmail; 430 } 431 elsif ( lc $user eq lc $curname && $mychk == 1 ) { 432 undef %memberinf; 433 return $curname; 434 } 435 } 436 elsif ( $memaction eq 'who_is' && ( lc $user eq lc $curmemb || lc $user eq lc $curmail || ($screenlogin && lc $user eq lc $curname ) ) ) { 437 undef %memberinf; 438 return $curmemb; 439 } 440 } 441 } 442# return; 443} 444 445sub MemberPostGroup { 446 my ($userpostcnt) = @_; 447 $grtitle = q{}; 448 foreach my $postamount ( reverse sort { $a <=> $b } keys %Post ) { 449 if ( $userpostcnt >= $postamount ) { 450 ( $grtitle, undef ) = split /\|/xsm, $Post{$postamount}, 2; 451 last; 452 } 453 } 454 return $grtitle; 455} 456 457sub MembershipCountTotal { 458 fopen( MEMBERLISTREAD, "$memberdir/memberlist.txt" ) 459 or fatal_error( 'cannot_open', "$memberdir/memberlist.txt", 1 ); 460 my @num = <MEMBERLISTREAD>; 461 fclose(MEMBERLISTREAD); 462 ( $latestmember, $meminfo ) = split /\t/xsm, $num[-1]; 463 my $membertotal = @num; 464 undef @num; 465 466 fopen( MEMTTL, ">$memberdir/members.ttl" ) 467 or fatal_error( 'cannot_open', "$memberdir/members.ttl", 1 ); 468 print {MEMTTL} qq~$membertotal|$latestmember~ 469 or croak "$croak{'print'} MEMTTL"; 470 fclose(MEMTTL); 471 472 if (wantarray) { 473 ManageMemberinfo('load'); 474 ( $latestrealname, undef ) = 475 split /\|/xsm, $memberinf{$latestmember}, 2; 476 undef %memberinf; 477 return ( $membertotal, $latestmember, $latestrealname ); 478 } 479 else { 480 return $membertotal; 481 } 482} 483 484sub RegApprovalCheck { 485 ## alert admins and gmods of waiting users for approval 486 if ( 487 $regtype == 1 488 && ( 489 $iamadmin 490 || ( $iamgmod 491 && $allow_gmod_admin eq 'on' 492 && $gmod_access{'view_reglog'} eq 'on' ) 493 ) 494 ) 495 { 496 opendir MEM, "$memberdir"; 497 my @approval = ( grep { /.wait$/ixsm } readdir MEM ); 498 closedir MEM; 499 my $app_waiting = $#approval + 1; 500 if ( $app_waiting == 1 ) { 501 $yyadmin_alert .= 502qq~<div class="editbg">$reg_txt{'admin_alert_start_one'} $app_waiting $reg_txt{'admin_alert_one'} <a href="$boardurl/AdminIndex.$yyaext?action=view_reglog">$reg_txt{'admin_alert_end'}</a></div>~; 503 } 504 elsif ( $app_waiting > 1 ) { 505 $yyadmin_alert .= 506qq~<div class="editbg">$reg_txt{'admin_alert_start_more'} $app_waiting $reg_txt{'admin_alert_more'} <a href="$boardurl/AdminIndex.$yyaext?action=view_reglog">$reg_txt{'admin_alert_end_more'}</a></div>~; 507 } 508 } 509 ## alert admins and gmods of waiting users for validations 510 if ( 511 ( $regtype == 1 || $regtype == 2 ) 512 && ( 513 $iamadmin 514 || ( $iamgmod 515 && $allow_gmod_admin eq 'on' 516 && $gmod_access{'view_reglog'} eq 'on' ) 517 ) 518 ) 519 { 520 opendir MEM, "$memberdir"; 521 my @preregged = ( grep { /.pre$/ixsm } readdir MEM ); 522 closedir MEM; 523 my $preregged_waiting = $#preregged + 1; 524 if ( $preregged_waiting == 1 ) { 525 $yyadmin_alert .= 526qq~<div class="editbg">$reg_txt{'admin_alert_start_one'} $preregged_waiting $reg_txt{'admin_alert_act_one'} <a href="$boardurl/AdminIndex.$yyaext?action=view_reglog">$reg_txt{'admin_alert_act_end'}</a></div>~; 527 } 528 elsif ( $preregged_waiting > 1 ) { 529 $yyadmin_alert .= 530qq~<div class="editbg">$reg_txt{'admin_alert_start_more'} $preregged_waiting $reg_txt{'admin_alert_act_more'} <a href="$boardurl/AdminIndex.$yyaext?action=view_reglog">$reg_txt{'admin_alert_act_end_more'}</a></div>~; 531 } 532 } 533 return; 534} 535 536sub activation_check { 537 my ( $changed, $regtime, $regmember ); 538 my $timespan = $preregspan * 3600; 539 fopen( INACT, "$memberdir/memberlist.inactive" ); 540 my @actlist = <INACT>; 541 fclose(INACT); 542 543 # check if user is in pre-registration and check activation key 544 foreach (@actlist) { 545 ( $regtime, undef, $regmember, undef ) = split /\|/xsm, $_, 4; 546 if ( $date - $regtime > $timespan ) { 547 $changed = 1; 548 unlink "$memberdir/$regmember.pre"; 549 550 # add entry to registration log 551 fopen( REGLOG, ">>$vardir/registration.log", 1 ); 552 print {REGLOG} "$date|T|$regmember|\n" 553 or croak "$croak{'print'} REGLOG"; 554 fclose(REGLOG); 555 } 556 else { 557 558 # update non activate user list 559 # write valid registration to the list again 560 push @outlist, $_; 561 } 562 } 563 if ($changed) { 564 565 # re-open inactive list for update if changed 566 fopen( INACT, ">$memberdir/memberlist.inactive", 1 ); 567 print {INACT} @outlist or croak "$croak{'print'} INACT"; 568 fclose(INACT); 569 } 570 return; 571} 572 573sub MakeStealthURL { 574 575# Usage is simple - just call MakeStealthURL with any url, and it will stealthify it. 576# if stealth urls are turned off, it just gives you the same value back 577 my ($theurl) = @_; 578 if ($stealthurl) { 579 $theurl =~ 580s/([^\w\"\=\[\]]|[\n\b]|\A)\\*(\w+:\/\/[\w\~\.\;\:\,\$\-\+\!\*\?\/\=\&\@\#\%]+\.[\w\~\;\:\$\-\+\!\*\?\/\=\&\@\#\%]+[\w\~\;\:\$\-\+\!\*\?\/\=\&\@\#\%])/$boardurl\/$yyexec.$yyext?action=dereferer;url=$2/isgm; 581 $theurl =~ 582s/([^\"\=\[\]\/\:\.(\:\/\/\w+)]|[\n\b]|\A)\\*(www\.[^\.][\w\~\.\;\:\,\$\-\+\!\*\?\/\=\&\@\#\%]+\.[\w\~\;\:\$\-\+\!\*\?\/\=\&\@\#\%]+[\w\~\;\:\$\-\+\!\*\?\/\=\&\@\#\%])/$boardurl\/$yyexec.$yyext?action=dereferer;url=http:\/\/$2/isgm; 583 } 584 return $theurl; 585} 586 587sub arraysort { 588 589 # usage: &arraysort(1,"|","R",@array_to_sort); 590 591 my ( $sortfield, $delimiter, $reverse, @in ) = @_; 592 my ( @out, @sortkey, %newline, $n ); 593 foreach my $oldline (@in) { 594 my @sk = split /$delimiter/xsm, $oldline; 595 $sk[$sortfield] = 596 "$sk[$sortfield]-$n"; ## make sure that identical keys are avoided ## 597 $n++; 598 $newline{ $sk[$sortfield] } = $oldline; 599 } 600 @sortkey = sort keys %newline; 601 if ($reverse) { 602 @sortkey = reverse @sortkey; 603 } 604 foreach (@sortkey) { 605 push @out, $newline{$_}; 606 } 607 return @out; 608} 609 610sub keygen { 611 ## length = output length, type = A (All), U (Uppercase), L (lowercase) ## 612 my ( $length, $type ) = @_; 613 if ( $length <= 0 || $length > 10_000 || !$length ) { return; } 614 $type = uc $type; 615 if ( $type ne 'A' && $type ne 'U' && $type ne 'L' ) { $type = 'A'; } 616 617 # generate random ID for password reset or other purposes. 618 @chararray = 619 qw(0 1 2 3 4 5 6 7 8 9 a b c d e f g h i j k l m n o p q r s t u v w x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z); 620 my $randid; 621 for my $i ( 0 .. ( $length - 1 ) ) { 622 $randid .= $chararray[ int rand 61 ]; 623 } 624 if ( $type eq 'U' ) { return uc $randid; } 625 elsif ( $type eq 'L' ) { return lc $randid; } 626 else { return $randid; } 627} 628 629## Sticky Shimmy Shuffle by astro-pilot ## 630## added to core on February 22, 2013 ## 631sub Rearrange_Sticky { 632 my ( $i, $upstky, $downstky, $stkynum, $stky, @stickies, $oldboard ); 633 $board = $INFO{'board'}; 634 $stkynum = $INFO{'num'}; 635 $direction = $INFO{'direction'}; 636 $oldboard = $INFO{'oldboard'}; 637 fopen( FILE, "$boardsdir/$board.txt" ) 638 or fatal_error( 639 "300 $messageindex_txt{'106'}: $messageindex_txt{'23'} $board.txt"); 640 @threads = <FILE>; 641 fclose(FILE); 642 my $n = 0; 643 644 foreach (@threads) { 645 my ( 646 $mnum, $msub, $mname, $memail, $mdate, 647 $mreplies, $musername, $micon, $mstate 648 ) = split /\|/xsm, $_; 649 if ( $mstate =~ /(s|a)/ism && $mnum eq $stkynum ) { $stky = $n; } 650 if ( $mstate =~ /(s|a)/ism ) { push @stickies, $_; $n++; } 651 if ( $mstate =~ /s/ism ) { $_ = q{}; } 652 } 653 if ( $direction eq 'down' && $stky != $#stickies ) { 654 $i = $stky; 655 $i++; 656 $downstky = $stickies[$stky]; 657 $upstky = $stickies[$i]; 658 $stickies[$stky] = $upstky; 659 $stickies[$i] = $downstky; 660 } 661 if ( $direction eq 'up' && $stky != 0 ) { 662 $i = $stky; 663 $i--; 664 $downstky = $stickies[$i]; 665 $upstky = $stickies[$stky]; 666 $stickies[$i] = $upstky; 667 $stickies[$stky] = $downstky; 668 } 669 if ($oldboard) { @threads = @stickies; $currentboard = $oldboard; } 670 else { push @threads, @stickies; } 671 if ( ( $direction ne 'up' || $stky != 0 ) 672 && ( $direction ne 'down' || $stky != $#stickies ) ) 673 { 674 fopen( FILE, ">$boardsdir/$board.txt" ) 675 or fatal_error( 676 "300 $messageindex_txt{'106'}: $messageindex_txt{'23'} $board.txt"); 677 foreach (@threads) { 678 chomp $_; 679 next if /^(\s)*$/xsm; 680 print {FILE} "$_\n" or croak "$croak{'print'} FILE"; 681 } 682 fclose(FILE); 683 } 684 $yySetLocation = qq~$scripturl?board=$currentboard;~; 685 redirectexit(); 686 return; 687} 688## End Sticky Shimmy Shuffle ## 689 6901; 691