1##---------------------------------------------------------------------------## 2## File: 3## $Id: mhutil.pl,v 2.34 2011/01/02 08:42:32 ehood Exp $ 4## Author: 5## Earl Hood mhonarc@mhonarc.org 6## Description: 7## Utility routines for MHonArc 8##---------------------------------------------------------------------------## 9## MHonArc -- Internet mail-to-HTML converter 10## Copyright (C) 1995-1999 Earl Hood, mhonarc@mhonarc.org 11## 12## This program is free software; you can redistribute it and/or modify 13## it under the terms of the GNU General Public License as published by 14## the Free Software Foundation; either version 2 of the License, or 15## (at your option) any later version. 16## 17## This program is distributed in the hope that it will be useful, 18## but WITHOUT ANY WARRANTY; without even the implied warranty of 19## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20## GNU General Public License for more details. 21## 22## You should have received a copy of the GNU General Public License 23## along with this program; if not, write to the Free Software 24## Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 25## 02111-1307, USA 26##---------------------------------------------------------------------------## 27 28package mhonarc; 29 30use MHonArc::RFC822; 31 32## RFC 2369 header fields to check for URLs 33%HFieldsList = ( 34 'list-archive' => 1, 35 'list-help' => 1, 36 'list-owner' => 1, 37 'list-post' => 1, 38 'list-subscribe' => 1, 39 'list-unsubscribe' => 1, 40); 41 42## Do not apply ADDRESSMODIFYCODE headerfields 43%HFieldsAsIsList = ( 44 %HFieldsList, 45 'content-disposition' => 1, 46 'content-id' => 1, 47 'content-type' => 1, 48 'message-id' => 1, 49 'references' => 1, 50 'in-reply-to' => 1, 51); 52 53## Header fields that contain addresses 54%HFieldsAddr = ( 55 'apparently-from' => 1, 56 'apparently-to' => 1, 57 'bcc' => 1, 58 'cc' => 1, 59 'dcc' => 1, 60 'from' => 1, 61 'mail-followup-to' => 1, 62 'mail-reply-to' => 1, 63 'notify-bcc' => 1, 64 'notify-cc' => 1, 65 'notify-to' => 1, 66 'original-bcc' => 1, 67 'original-cc' => 1, 68 'original-from' => 1, 69 'original-sender' => 1, 70 'original-to' => 1, 71 'reply-to' => 1, 72 'resent-bcc' => 1, 73 'resent-cc' => 1, 74 'resent-from' => 1, 75 'resent-sender' => 1, 76 'resent-to' => 1, 77 'return-path' => 1, 78 'sender' => 1, 79 'to' => 1, 80 'x-envelope' => 1, 81); 82 83##--------------------------------------------------------------------------- 84## Convert message header string to HTML encoded in 85## $readmail::TextEncode encoding. 86## 87sub htmlize_enc_head { 88 my ($cnvfunc, $charset) = 89 readmail::MAILload_charset_converter($readmail::TextEncode); 90 return htmlize($_[0]) 91 if ($cnvfunc eq '-decode-' || $cnvfunc eq '-ignore-'); 92 return &$cnvfunc($_[0], $charset); 93} 94 95##--------------------------------------------------------------------------- 96## Clip text to specified length. 97## 98sub clip_text { 99 my $str = \shift; # Prevent unnecessary copy. 100 my $len = shift; # Clip length 101 my $is_html = shift; # If entity references should be considered 102 my $has_tags = shift; # If html tags should be stripped 103 104 if (!$is_html) { 105 return substr($$str, 0, $len); 106 } 107 108 my $text = ""; 109 my $subtext = ""; 110 my $html_len = length($$str); 111 my ($pos, $sublen, $real_len, $semi); 112 my $er_len = 0; 113 114 for ($pos = 0, $sublen = $len; $pos < $html_len;) { 115 $subtext = substr($$str, $pos, $sublen); 116 $pos += $sublen; 117 118 # strip tags 119 if ($has_tags) { 120 # Strip full tags 121 $subtext =~ s/<[^>]*>//g; 122 # Check if clipped part of a tag 123 if ($subtext =~ s/<[^>]*\Z//) { 124 my $gt = index($$str, '>', $pos); 125 $pos = ($gt < 0) ? $html_len : ($gt + 1); 126 } 127 } 128 129 # check for clipped entity reference 130 if (($pos < $html_len) && ($subtext =~ /\&[^;]*\Z/)) { 131 my $semi = index($$str, ';', $pos); 132 if ($semi < 0) { 133 # malformed entity reference 134 $subtext .= substr($$str, $pos); 135 $pos = $html_len; 136 } else { 137 $subtext .= substr($$str, $pos, $semi - $pos + 1); 138 $pos = $semi + 1; 139 } 140 } 141 142 # compute entity reference lengths to determine "real" character 143 # count and not raw character count. 144 while ($subtext =~ /(\&[^;]+);/g) { 145 $er_len += length($1); 146 } 147 148 $text .= $subtext; 149 150 # done if we have enough 151 $real_len = length($text) - $er_len; 152 if ($real_len >= $len) { 153 last; 154 } 155 $sublen = $len - (length($text) - $er_len); 156 } 157 $text; 158} 159 160##--------------------------------------------------------------------------- 161## Get an e-mail address from (HTML) $str. 162## 163sub extract_email_address { 164 return '' unless defined $_[0]; 165 scalar(MHonArc::RFC822::first_addr_spec(shift)); 166} 167 168##--------------------------------------------------------------------------- 169## Get an e-mail name from $str. 170## 171sub extract_email_name { 172 my @tokens = MHonArc::RFC822::tokenise(shift); 173 my @bare = (); 174 my $possible = undef; 175 my $skip = 0; 176 177 my $tok; 178 foreach $tok (@tokens) { 179 next if $skip; 180 if ($tok =~ /^"/) { # Quoted string 181 $tok =~ s/^"//; 182 $tok =~ s/"$//; 183 $tok =~ s/\\(.)/$1/g; 184 return $tok; 185 } 186 if ($tok =~ /^\(/) { # Comment 187 $tok =~ s/^\(//; 188 $tok =~ s/\)$//; 189 $tok =~ s/\\(.)/$1/g; 190 return $tok; 191 } 192 if ($tok =~ /^<$/) { # Address spec, skip 193 $skip = 1; 194 next; 195 } 196 if ($tok =~ /^>$/) { 197 $skip = 0; 198 next; 199 } 200 push(@bare, $tok); # Bare name 201 } 202 203 my $str; 204 if (@bare) { 205 $str = join(' ', @bare); 206 $str =~ s/@.*//; 207 $str =~ s/^\s+//; 208 $str =~ s/\s+$//; 209 return $str; 210 } 211 $str = MHonArc::RFC822::first_addr_spec(@tokens); 212 $str =~ s/@.*//; 213 $str; 214} 215 216##--------------------------------------------------------------------------- 217## Routine to sort messages 218## 219sub sort_messages { 220 my ($nosort, $subsort, $authsort, $revsort) = @_; 221 $nosort = $NOSORT if !defined($nosort); 222 $subsort = $SUBSORT if !defined($subsort); 223 $authsort = $AUTHSORT if !defined($authsort); 224 $revsort = $REVSORT if !defined($revsort); 225 226 if ($nosort) { 227 ## Process order 228 if ($revsort) { 229 return sort { $IndexNum{$b} <=> $IndexNum{$a} } keys %Subject; 230 } else { 231 return sort { $IndexNum{$a} <=> $IndexNum{$b} } keys %Subject; 232 } 233 234 } elsif ($subsort) { 235 ## Subject order 236 my (%sub, $idx, $sub); 237 use locale; 238 eval { 239 my $hs = scalar(%Subject); 240 $hs =~ s|^[^/]+/||; 241 keys(%sub) = $hs; 242 }; 243 while (($idx, $sub) = each(%Subject)) { 244 $sub = lc $sub; 245 1 while $sub =~ s/$SubReplyRxp//io; 246 $sub =~ s/$SubArtRxp//io; 247 $sub{$idx} = $sub; 248 } 249 if ($revsort) { 250 return 251 sort { ($sub{$a} cmp $sub{$b}) || ($Time{$b} <=> $Time{$a}) } 252 keys %Subject; 253 } else { 254 return 255 sort { ($sub{$a} cmp $sub{$b}) || ($Time{$a} <=> $Time{$b}) } 256 keys %Subject; 257 } 258 259 } elsif ($authsort) { 260 ## Author order 261 my (%from, $idx, $from); 262 use locale; 263 eval { 264 my $hs = scalar(%From); 265 $hs =~ s|^[^/]+/||; 266 keys(%from) = $hs; 267 }; 268 if ($DoFromName && %FromName) { 269 while (($idx, $from) = each(%FromName)) { 270 $from{$idx} = lc $from; 271 } 272 } else { 273 while (($idx, $from) = each(%From)) { 274 $from{$idx} = lc extract_email_name($from); 275 } 276 } 277 if ($revsort) { 278 return sort { 279 ($from{$a} cmp $from{$b}) 280 || ($Time{$b} <=> $Time{$a}) 281 } keys %Subject; 282 } else { 283 return sort { 284 ($from{$a} cmp $from{$b}) 285 || ($Time{$a} <=> $Time{$a}) 286 } keys %Subject; 287 } 288 289 } else { 290 ## Date order 291 if ($revsort) { 292 return sort { 293 ($Time{$b} <=> $Time{$a}) 294 || ($IndexNum{$b} <=> $IndexNum{$a}) 295 } keys %Subject; 296 } else { 297 return sort { 298 ($Time{$a} <=> $Time{$b}) 299 || ($IndexNum{$a} <=> $IndexNum{$b}) 300 } keys %Subject; 301 } 302 303 } 304} 305 306##--------------------------------------------------------------------------- 307## Message-sort routines for sort(). 308## 309sub increase_index { 310 (&get_time_from_index($a) <=> &get_time_from_index($b)) 311 || ($IndexNum{$a} <=> $IndexNum{$b}); 312} 313 314##--------------------------------------------------------------------------- 315## Routine for formating a message number for use in filenames or links. 316## 317sub fmt_msgnum { 318 sprintf("%05d", $_[0]); 319} 320 321##--------------------------------------------------------------------------- 322## Routine to get filename of a message number. 323## 324sub msgnum_filename { 325 my ($fmtstr) = "$MsgPrefix%05d.$HtmlExt"; 326 $fmtstr .= ".gz" if $GzipLinks; 327 sprintf($fmtstr, $_[0]); 328} 329 330##--------------------------------------------------------------------------- 331## Routine to get filename of an index 332## 333sub get_filename_from_index { 334 &msgnum_filename($IndexNum{$_[0]}); 335} 336 337##--------------------------------------------------------------------------- 338## Routine to get time component from index 339## 340sub get_time_from_index { 341 $Time{$_[0]} || (split(/$X/o, $_[0], 2))[0]; 342} 343 344##--------------------------------------------------------------------------- 345## Routine to get annotation of a message 346## 347sub get_note { 348 my $index = shift; 349 my $file = join($DIRSEP, get_note_dir(), 350 msgid_to_filename($Index2MsgId{$index})); 351 if (!open(NOTEFILE, $file)) { return ""; } 352 my $ret = join("", <NOTEFILE>); 353 close NOTEFILE; 354 $ret; 355} 356 357##--------------------------------------------------------------------------- 358## Routine to determine if a message has an annotation 359## 360sub note_exists { 361 my $index = shift; 362 -e join($DIRSEP, get_note_dir(), msgid_to_filename($Index2MsgId{$index})); 363} 364 365##--------------------------------------------------------------------------- 366## Routine to get full pathname to annotation directory 367## 368sub get_note_dir { 369 if (!OSis_absolute_path($NoteDir)) { 370 return join($DIRSEP, $OUTDIR, $NoteDir); 371 } 372 $NoteDir; 373} 374 375##--------------------------------------------------------------------------- 376## Routine to get lc author name from index 377## 378sub get_base_author { 379 if ($DoFromName && %FromName) { 380 return lc $FromName{$_[0]}; 381 } 382 lc extract_email_name($From{$_[0]}); 383} 384 385##--------------------------------------------------------------------------- 386## Determine time from date. Use %Zone for timezone offsets 387## 388sub get_time_from_date { 389 my ($mday, $mon, $yr, $hr, $min, $sec, $zone) = @_; 390 my ($time) = 0; 391 392 $yr -= 1900 if $yr >= 1900; # if given full 4 digit year 393 $yr += 100 if $yr <= 37; # in case of 2 digit years 394 if (($yr < 70) || ($yr > 137)) { 395 warn "Warning: Bad year (", $yr + 1900, ") using current\n"; 396 $yr = (localtime(time))[5]; 397 } 398 399 ## If $zone, grab gmt time, else grab local 400 if ($zone) { 401 $zone =~ tr/a-z/A-Z/; 402 $time = &timegm($sec, $min, $hr, $mday, $mon, $yr); 403 404 # try to modify time/date based on timezone 405 OFFSET: { 406 # numeric timezone 407 if ($zone =~ /^[\+-]\d+$/) { 408 $time -= &zone_offset_to_secs($zone); 409 last OFFSET; 410 } 411 # Zone 412 if (defined($Zone{$zone})) { 413 # timezone abbrev 414 $time += &zone_offset_to_secs($Zone{$zone}); 415 last OFFSET; 416 417 } 418 # Zone[+-]DDDD 419 if ($zone =~ /^([A-Z]\w+)([\+-]\d+)$/) { 420 $time -= &zone_offset_to_secs($2); 421 if (defined($Zone{$1})) { 422 $time += &zone_offset_to_secs($Zone{$1}); 423 last OFFSET; 424 } 425 } 426 # undefined timezone 427 warn qq|Warning: Unrecognized time zone, "$zone"\n|; 428 } 429 430 } else { 431 $time = &timelocal($sec, $min, $hr, $mday, $mon, $yr); 432 } 433 $time; 434} 435 436##--------------------------------------------------------------------------- 437## Routine to check if time has expired. 438## 439sub expired_time { 440 ($ExpireTime && (time - $_[0] > $ExpireTime)) 441 || ($_[0] < $ExpireDateTime); 442} 443 444##--------------------------------------------------------------------------- 445## Get HTML tags for formatting message headers 446## 447sub get_header_tags { 448 my ($f) = shift; 449 my ($ftago, $ftagc, $tago, $tagc); 450 451 ## Get user specified tags (this is one funcky looking code) 452 $tag = 453 (defined($HeadHeads{$f}) ? $HeadHeads{$f} : $HeadHeads{"-default-"}); 454 $ftag = ( 455 defined($HeadFields{$f}) 456 ? $HeadFields{$f} 457 : $HeadFields{"-default-"} 458 ); 459 if ($tag) { $tago = "<$tag>"; $tagc = "</$tag>"; } 460 else { $tago = $tagc = ''; } 461 if ($ftag) { $ftago = "<$ftag>"; $ftagc = "</$ftag>"; } 462 else { $ftago = $ftagc = ''; } 463 464 ($tago, $tagc, $ftago, $ftagc); 465} 466 467##--------------------------------------------------------------------------- 468## Format message headers in HTML. 469## $html = htmlize_header($fields_hash_ref); 470## 471sub htmlize_header { 472 my $fields = shift; 473 my ($key, $tago, $tagc, $ftago, $ftagc, $item, @array); 474 my ($tmp); 475 476 my $mesg = ""; 477 my %hf = %$fields; 478 foreach $item (@FieldOrder) { 479 if ($item eq '-extra-') { 480 foreach $key (sort keys %hf) { 481 next if $FieldODefs{$key}; 482 next if $key =~ /^x-mha-/; 483 delete $hf{$key}, next if &exclude_field($key); 484 485 @array = @{$hf{$key}}; 486 foreach $tmp (@array) { 487 $tmp = 488 $HFieldsList{$key} 489 ? mlist_field_add_links($tmp) 490 : &$MHeadCnvFunc($tmp); 491 $tmp = field_add_links($key, $tmp, $fields) 492 unless $HFieldsAsIsList{$key}; 493 ($tago, $tagc, $ftago, $ftagc) = get_header_tags($key); 494 $mesg .= join('', 495 $LABELBEG, $tago, 496 htmlize(ucfirst($key)), $tagc, 497 $LABELEND, $FLDBEG, 498 $ftago, $tmp, 499 $ftagc, $FLDEND, 500 "\n"); 501 } 502 delete $hf{$key}; 503 } 504 } else { 505 if (!&exclude_field($item) && $hf{$item}) { 506 @array = @{$hf{$item}}; 507 foreach $tmp (@array) { 508 $tmp = 509 $HFieldsList{$item} 510 ? mlist_field_add_links($tmp) 511 : &$MHeadCnvFunc($tmp); 512 $tmp = field_add_links($item, $tmp, $fields) 513 unless $HFieldsAsIsList{$item}; 514 ($tago, $tagc, $ftago, $ftagc) = &get_header_tags($item); 515 $mesg .= join('', 516 $LABELBEG, $tago, 517 htmlize(ucfirst($item)), $tagc, 518 $LABELEND, $FLDBEG, 519 $ftago, $tmp, 520 $ftagc, $FLDEND, 521 "\n"); 522 } 523 } 524 delete $hf{$item}; 525 } 526 } 527 if ($mesg) { $mesg = $FIELDSBEG . $mesg . $FIELDSEND; } 528 $mesg; 529} 530 531##--------------------------------------------------------------------------- 532 533sub mlist_field_add_links { 534 my $txt = shift; 535 my $ret = ""; 536 local ($_); 537 foreach (split(/(<[^<>]+>)/, $txt)) { 538 if (/^<\w+:/) { 539 chop; 540 substr($_, 0, 1) = ""; 541 $ret .= qq|<<a href="$_">$_</a>>|; 542 } else { 543 $ret .= &$MHeadCnvFunc($_); 544 } 545 } 546 $ret; 547} 548 549##--------------------------------------------------------------------------- 550## Routine to add mailto/news links to a message header string. 551## 552sub field_add_links { 553 my $label = lc shift; 554 my $fld_text = shift; 555 my $fields = shift; 556 557LBLSW: { 558 if (!$NONEWS && ($label eq 'newsgroup' || $label eq 'newsgroups')) { 559 $fld_text = newsurl($fld_text, $fields->{'x-mha-message-id'}); 560 last LBLSW; 561 } 562 if (!$NOMAILTO) { 563 $fld_text =~ s{($HAddrExp)} 564 {&mailUrl($1, $fields->{'x-mha-message-id'}, 565 $fields->{'x-mha-subject'}, 566 $fields->{'x-mha-from'}); 567 }gexo; 568 } else { 569 $fld_text =~ s{($HAddrExp)} 570 {&htmlize(&rewrite_address($1)) 571 }gexo; 572 } 573 last LBLSW; 574 } 575 $fld_text; 576} 577 578##--------------------------------------------------------------------------- 579## Routine to add news links of newsgroups names 580## 581sub newsurl { 582 my $str = shift; 583 my $msgid_u = urlize(shift); 584 my $h = ""; 585 586 local $_; 587 if ($str =~ s/^([^:]*:\s*)//) { 588 $h = $1; 589 } 590 $str =~ s/[\s<>]//g; 591 my @groups = split(/,/, $str); 592 my $group; 593 foreach $group (@groups) { 594 my $url = $NewsUrl; 595 my $group_u = urlize($group); 596 $url =~ s/\$NEWSGROUP(?::U)?\$/$group_u/g; 597 $url =~ s/\$MSGID(?::U)?\$/$msgid_u/g; 598 $group = qq{<a href="$url">$group</a>}; 599 } 600 $h . join(', ', @groups); # Rejoin string 601} 602 603##--------------------------------------------------------------------------- 604## $html = mailUrl($email_addr, $msgid, $subject, $from); 605## 606sub mailUrl { 607 my $eaddr = shift || ''; 608 my $msgid = shift || ''; 609 my $sub = shift || ''; 610 my $from = shift || ''; 611 dehtmlize(\$eaddr); 612 613 local $_; 614 my ($url) = ($MAILTOURL); 615 my ($to) = (&urlize($eaddr)); 616 my ($toname, $todomain) = map { urlize($_) } split(/@/, $eaddr, 2); 617 my ($froml, $msgidl) = (&urlize($from), &urlize($msgid)); 618 my ($fromaddrl) = (&extract_email_address($from)); 619 my ($faddrnamel, $faddrdomainl) = 620 map { urlize($_) } split(/@/, $fromaddrl, 2); 621 $fromaddrl = &urlize($fromaddrl); 622 my ($subjectl); 623 624 # Add "Re:" to subject if not present 625 if ($sub !~ /^$SubReplyRxp/io) { 626 $subjectl = 'Re:%20' . &urlize($sub); 627 } else { 628 $subjectl = &urlize($sub); 629 } 630 $url =~ s/\$FROM\$/$froml/g; 631 $url =~ s/\$FROMADDR\$/$fromaddrl/g; 632 $url =~ s/\$FROMADDRNAME\$/$faddrnamel/g; 633 $url =~ s/\$FROMADDRDOMAIN\$/$faddrdomainl/g; 634 $url =~ s/\$MSGID\$/$msgidl/g; 635 $url =~ s/\$SUBJECT(?:NA)?\$/$subjectl/g; 636 $url =~ s/\$TO\$/$to/g; 637 $url =~ s/\$TOADDRNAME\$/$toname/g; 638 $url =~ s/\$TOADDRDOMAIN\$/$todomain/g; 639 $url =~ s/\$ADDR\$/$to/g; 640 qq|<a href="$url">| . &htmlize(&rewrite_address($eaddr)) . q|</a>|; 641} 642 643##---------------------------------------------------------------------------## 644## Routine to parse variable definitions in a string. The 645## function returns a list of variable/value pairs. The format of 646## the string is similiar to attribute specification lists in 647## SGML, but NAMEs are any non-whitespace character. 648## 649sub parse_vardef_str { 650 my ($org) = shift; 651 my ($lower) = shift; 652 my (%hash) = (); 653 my ($str, $q, $var, $value); 654 655 ($str = $org) =~ s/^\s+//; 656 while ($str =~ s/^([^=\s]+)\s*=\s*//) { 657 $var = $1; 658 if ($str =~ s/^(['"])//) { 659 $q = $1; 660 if (!( $q eq "'" 661 ? $str =~ s/^([^']*)'// 662 : $str =~ s/^([^"]*)"// 663 ) 664 ) { 665 warn "Warning: Unclosed quote in: $org\n"; 666 return (); 667 } 668 $value = $1; 669 670 } else { 671 if ($str =~ s/^(\S+)//) { 672 $value = $1; 673 } else { 674 warn "Warning: No value after $var in: $org\n"; 675 return (); 676 } 677 } 678 $str =~ s/^\s+//; 679 $hash{$lower ? lc($var) : $var} = $value; 680 } 681 if ($str =~ /\S/) { 682 warn "Warning: Trailing characters in: $org\n"; 683 } 684 %hash; 685} 686 687##---------------------------------------------------------------------------## 688 689sub msgid_to_filename { 690 my $msgid = shift; 691 if ($VMS) { 692 $msgid =~ s/([^\w\-])/sprintf("=%02X",unpack("C",$1))/geo; 693 } else { 694 $msgid =~ s/([^\w.\-\@])/sprintf("=%02X",unpack("C",$1))/geo; 695 } 696 $msgid; 697} 698 699##---------------------------------------------------------------------------## 700## Check if new follow up list for a message is different from 701## old follow up list. 702## 703sub is_follow_ups_diff { 704 my $f = $Follow{$_[0]}; 705 my $o = $FollowOld{$_[0]}; 706 if (defined($f) && defined($o)) { 707 return 1 unless @$f == @$o; 708 local $^W = 0; 709 my $i; 710 for ($i = 0; $i < @$f; ++$i) { 711 return 1 if $f->[$i] ne $o->[$i]; 712 } 713 return 0; 714 } 715 return (defined($f) || defined($o)); 716} 717 718##---------------------------------------------------------------------------## 719## Retrieve icon URL for specified content-type. 720## 721sub get_icon_url { 722 my $ctype = shift; 723 my $icon = $Icons{$ctype}; 724ICON: { 725 last ICON if defined $icon; 726 if ($ctype =~ s|/.*||) { 727 $ctype .= '/*'; 728 $icon = $Icons{$ctype}; 729 last ICON if defined $icon; 730 } 731 $icon = $Icons{'*/*'} || $Icons{'unknown'}; 732 } 733 if (!defined($icon)) { 734 return (undef, undef, undef); 735 } 736 if ($icon =~ s/\[(\d+)x(\d+)\]//) { 737 return ($IconURLPrefix . $icon, $1, $2); 738 } 739 ($IconURLPrefix . $icon, undef, undef); 740} 741 742##---------------------------------------------------------------------------## 743 744sub log_mesg { 745 my $fh = shift; 746 my $doDate = shift; 747 748 if ($doDate) { 749 my ($sec, $min, $hour, $mday, $mon, $year) = localtime(time); 750 print $fh sprintf( 751 "[%4d-%02d-%02d %02d:%02d:%02d] ", 752 $year + 1900, 753 $mon + 1, $mday, $hour, $min, $sec 754 ); 755 } 756 print $fh @_; 757} 758 759##---------------------------------------------------------------------------## 760 761sub dump_hash { 762 my $fh = shift; 763 my $h = shift; 764 local $_; 765 foreach (sort keys %$h) { 766 print $fh "$_ => ", $h->{$_}, "\n"; 767 } 768} 769 770##---------------------------------------------------------------------------## 7711; 772