1#!/usr/local/bin/perl 2 3# $Header: /mhub4/sources/imap-tools/maildir_to_imap.pl,v 1.5 2012/02/29 01:19:37 rick Exp $ 4 5########################################################################## 6# Program name maildir_to_imap.pl # 7# Written by Rick Sanders # 8# # 9# Description # 10# # 11# maildir_to_imap is used to copy the messages in a maildir to a # 12# user's IMAP mailbox. maildir_to_imap is executed like this: # 13# # 14# ./maildir_to_imap.pl -i <user list> -D <imapserver[:port]> # 15# # 16# The user list is a file with one or more entries containing the # 17# location of the user's maildir and his IMAP username and password. # 18# # 19# For example: # 20# /mhub4/maildirs/rwilson@abc.net,rich.wilson,welcome # 21# /mhub4/maildirs/jane.eyre@abc.net,jane.eyre,mypass # 22# # 23# See usage() for a list of arguments # 24########################################################################## 25 26use IMAP::Utils; 27 28init(); 29$debug = 1; 30get_user_list( \@users ); 31migrate_user_list( \@users ); 32 33exit; 34 35 36sub migrate_user_list { 37 38my $users = shift; 39 40 # Migrate a set of users 41 42 foreach $userinfo ( @$users ) { 43 $usercount++; 44 ($user) = split(/\s*,\s*/, $userinfo); 45 Log("migrate $user"); 46 47 # Start the migration. Unless maxChildren has been set to 1 48 # fork off child processes to do the migration in parallel. 49 50 if ($maxChildren == 1) { 51 migrate ($userinfo, $imaphost); 52 } else { 53 Log("There are $children running") if $debug; 54 if ( $children < $maxChildren ) { 55 Log(" Forking to migrate $user") if $debug; 56 if ( $pid = fork ) { # Parent 57 Log (" Parent $$ forked $pid") if $debug; 58 } elsif (defined $pid) { # Child 59 Log (" Child process $$ processing $sourceUser") if $debug; 60 migrate($userinfo, $imaphost); 61 Log(" $user is done"); 62 exit 0; 63 } else { 64 Log("Error forking child to migrate $user"); 65 next; 66 } 67 $children++; 68 $children{$pid} = $user; 69 } 70 71 Log ("I'm PID $$") if $debug; 72 while ( $children >= $maxChildren ) { 73 Log(" $$ - Max children running. Waiting...") if $debug; 74 $foundPid = wait; # Wait for a child to terminate 75 if ($? != 0) { 76 Log ("ERROR: PID $foundPid exited with status $?"); 77 } 78 delete $children{$foundPid}; 79 $children--; 80 } 81 Log("OK to launch another user migration") if $debug; 82 } 83 84} 85} 86 87sub xxxx { 88 89 if ($maxChildren > 1) { 90 Log("All children have been launched, waiting for them to finish"); 91 foreach $pid ( keys(%children) ) { 92 $user = $children{$pid}; 93 Log("Waiting on process $pid ($user) to finish"); 94 waitpid($pid, 0); 95 if ($? != 0) { 96 Log ("ERROR: PID $pid exited with status $?"); 97 } 98 } 99 } 100} 101 102 103sub sum { 104summarize(); 105$elapsed = sprintf("%.2f", (time()-$start)/3600); 106Log("Elapsed time $elapsed hours"); 107Log("Migration completed"); 108exit; 109} 110 111sub migrate { 112 113my $userinfo = shift; 114my $imaphost = shift; 115 116 my ($user,$pwd,$userpath) = split(/,/, $userinfo); 117 118 return unless connectToHost($imaphost, \$dst); 119 return unless login($user,$pwd, $dst); 120 121 get_maildir_folders( $userpath, \%folders ); 122 123 my $messages; 124 foreach $maildir_folder ( keys %folders ) { 125 print STDERR "maildir_folder $maildir_folder\n"; 126 $maildir_folder =~ s/\&/&-/; # Encode the '&' char 127 $maildir_folder =~ s/\s+$//; 128 $folder_path = $folders{"$maildir_folder"}; 129 createMbx( $maildir_folder, $dst ) unless mbxExists( $maildir_folder, $dst ); 130 131 get_maildir_msgs( $folder_path, \@msgs ); 132 my $msgcount = $#msgs + 1; 133 Log(" $maildir_folder ($msgcount msgs) $folder_path"); 134 135 next if !@msgs; 136 137 $inserted=0; 138 foreach $msgfn ( @msgs ) { 139 $inserted++ if insert_msg( $msgfn, $maildir_folder, $dst ); 140 } 141 Log(" Inserted $inserted messages into $maildir_folder\n"); 142 } 143 144 $conn_timed_out=0; 145 146} 147 148sub init { 149 150use Getopt::Std; 151use Fcntl; 152use Socket; 153use IO::Socket; 154use sigtrap; 155use FileHandle; 156require "ctime.pl"; 157 158 $start = time(); 159 160 # Set up signal handling 161 $SIG{'ALRM'} = 'signalHandler'; 162 $SIG{'HUP'} = 'signalHandler'; 163 $SIG{'INT'} = 'signalHandler'; 164 $SIG{'TERM'} = 'signalHandler'; 165 $SIG{'URG'} = 'signalHandler'; 166 167 getopts('H:i:L:n:ht:M:SLdD:Um:I'); 168 169 # usage() if $opt_h; 170 # usage(); 171 172 $userlist = $opt_i; 173 $logfile = $opt_L; 174 $maxChildren = $opt_n; 175 $usage = $opt_h; 176 $timeout = $opt_t; 177 $imaphost = $opt_H; 178 $imaphost = $opt_D; 179 $mbxList = $opt_m; 180 $debug=1 if $opt_d; 181 $showIMAP=1 if $opt_I; 182 183 $timeout = 45 unless $timeout; 184 $maxChildren = 1 unless $maxChildren; 185 186 IMAP::Utils::init(); 187 $logfile = "maildir_to_imap.log" unless $logfile; 188 openLog($logfile); 189 Log("$0 starting"); 190 191 $date = ctime(time); 192 chomp($date); 193 194} 195 196sub usage { 197 198 print "\nUsage: iu-maildirtoimap -i <users> -D imapHost\n\n"; 199 print "Optional arguments:\n\n"; 200 print " -i <file of usernames>\n"; 201 print " -n <number of simultaneous migration processes to run>\n"; 202 print " -m <list of mailboxes> eg Inbox,Drafts,Sent\n"; 203 print " -L <logfile, default is maildir_to_imap.log>\n"; 204 print " -t <timeout in seconds>\n"; 205 print " -d debug mode\n"; 206 print " -I record IMAP protocol exchanges\n\n"; 207 exit; 208 209} 210 211 212sub format_bytes { 213 214my $bytes = shift; 215 216 # Format the number nicely 217 218 if ( length($bytes) >= 10 ) { 219 $bytes = $bytes/1000000000; 220 $tag = 'GB'; 221 } elsif ( length($bytes) >= 7 ) { 222 $bytes = $bytes/1000000; 223 $tag = 'MB'; 224 } else { 225 $bytes = $bytes/1000; 226 $tag = 'KB'; 227 } 228 229 # commafy 230 $_ = $bytes; 231 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; 232 $bytes = sprintf("%.2f", $_) . " $tag"; 233 234 return $bytes; 235} 236 237 238sub commafy { 239 240my $number = shift; 241 242 $_ = $number; 243 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; 244 $number = $_; 245 246 return $number; 247} 248 249# Reconnect to a server after a timeout error. 250# 251sub reconnect { 252 253my $checkpoint = shift; 254my $conn = shift; 255 256 Log("This is reconnect, conn is $conn") if $debug; 257 logout( $conn ); 258 close $conn; 259 sleep 5; 260 ($mbx,$shost,$suser,$spwd,$dhost,$duser,$dpwd) = split(/\|/, $checkpoint); 261 if ( $conn eq $src ) { 262 $host = $shost; 263 $user = $suser; 264 $pwd = $spwd; 265 } else { 266 $host = $dhost; 267 $user = $duser; 268 $pwd = $dpwd; 269 } 270 connectToHost($host,$conn); 271 login($user,$pwd,$conn); 272 selectMbx( $mbx, $conn ); 273 createMbx( $mbx, $dst ); # Just in case 274 Log("leaving reconnect"); 275} 276 277# Handle signals 278 279sub signalHandler { 280 281my $sig = shift; 282 283 if ( $sig eq 'ALRM' ) { 284 Log("Caught a SIG$sig signal, timeout error"); 285 $conn_timed_out = 1; 286 } else { 287 Log("Caught a SIG$sig signal, shutting down"); 288 exit; 289 } 290} 291 292# Get the total message count and bytes and write 293# it to the log. 294 295sub summarize { 296 297 # Each child appends its totals to /tmp/migrateEmail.sum so 298 # we read the lines and add up the grand totals. 299 300 $totalUsers=$totalMsgs=$totalBytes=0; 301 open(SUM, "</tmp/migrateIMAP.sum"); 302 while ( <SUM> ) { 303 chomp; 304 ($msgs,$bytes) = split(/\|/, $_); 305 $totalUsers++; 306 $totalMsgs += $msgs; 307 $totalBytes += $bytes; 308 } 309 310 $_ = $totalMsgs; 311 1 while s/^([-+]?\d+)(\d{3})/$1,$2/; # Commafy the message total 312 $totalMsgs = $_; 313 $totalBytes = formatBytes( $totalBytes ); 314 315 Log("Summary of migration"); 316 Log("Migrated $totalUsers users, $totalMsgs messages, $totalBytes."); 317 318} 319 320sub fix_ts { 321 322my $date = shift; 323 324 # Make sure the hrs part of the date is 2 digits. At least 325 # one IMAP server expects this. 326 327 $$date =~ s/^\s+//; 328 $$date =~ /(.+) (.+):(.+):(.+) (.+)/; 329 my $hrs = $2; 330 331 return if length( $hrs ) == 2; 332 333 my $newhrs = '0' . $hrs if length( $hrs ) == 1; 334 $$date =~ s/ $hrs/ $newhrs/; 335 336} 337 338sub stats { 339 340 print "\n"; 341 print "Users migrated $users\n"; 342 print "Total messages $total_msgs\n"; 343 print "Total bytes $total_bytes\n"; 344 345 $elapsed = time() - $start; 346 $minutes = $elapsed/60; 347 print "Elapsed time $minutes minutes\n"; 348 349} 350 351sub processArgs { 352 353 if ( !getopts( "" ) ) { 354 usage(); 355 } 356} 357 358# Handle signals 359 360sub signalHandler { 361 362my $sig = shift; 363 364 if ( $sig eq 'ALRM' ) { 365 Log("Caught a SIG$sig signal, timeout error"); 366 $conn_timed_out = 1; 367 } else { 368 Log("Caught a SIG$sig signal, shutting down"); 369 exit; 370 } 371 Log("Resuming"); 372} 373 374sub insert_msg { 375 376my $msgfn = shift; 377my $folder = shift; 378my $dst = shift; 379 380 # Put a message in the user's folder 381 382# Log("insert $msgfn into $folder") if $debug; 383 384 my $flag = 'Unseen'; 385 if ( $msgfn =~ /,/ ) { 386 $flag = '\\Seen' if $msgfn =~ /,S$/; 387 } 388 389 if ( !open(MESSAGE, "<$msgfn")) { 390 Log( " Can't open message fn $msgfn: $!" ); 391 return 0; 392 } 393 my ($date,$message,$msgid); 394 while( <MESSAGE> ) { 395 chomp; 396 # print STDERR "message line $_\n"; 397 if ( /^Date: (.+)/ and !$date ) { 398 $date = $1; 399 } 400 if ( /^Message-Id: (.+)/i and !$msgid ) { 401 $msgid = $1; 402 Log("msgid $msgid") if $debug; 403 } 404 $message .= "$_\r\n"; 405 } 406 close MESSAGE; 407 408 fix_date( \$date ); 409 410 $status = insert_imap_msg( $dst, $folder, \$message, $flag, $date ); 411 412 return $status; 413 414} 415 416sub entry_exists { 417 418my $mail = shift; 419my $ldap = shift; 420my $pwd = shift; 421my $dn; 422my $i; 423 424 my $attrs = [ 'mailpassword' ]; 425 my $base = 'o=site'; 426 my $filter = "mail=$mail"; 427 428 my $result = $ldap->search( 429 base => $base, 430 filter => $filter, 431 scope => "subtree", 432 attrs => $attrs 433 ); 434 435 if ( $result->code ) { 436 my $error = $result->code; 437 my $errtxt = ldap_error_name( $result->code ); 438 Log("Error searching for $filter: $errtxt"); 439 exit; 440 } 441 442 my @entries = $result->entries; 443 my $i = $#entries + 1; 444 445 $entry = $entries[0]; 446 $$pwd = $entry->get_value( 'mailpassword' ); 447 448 return $i; 449} 450 451sub get_user_list { 452 453my $users = shift; 454 455 # Build a list of the users and their maildirs 456 457 open(F, "<$userlist") or die "Can't open user list $userlist: $!"; 458 while( <F> ) { 459 chomp; 460 s/^\s+//; 461 next if /^#/; 462 next unless $_; 463 my( $maildir,$user,$pwd) = split(/,/, $_); 464 push( @$users, "$user,$pwd,$maildir" ); 465 } 466 close F; 467 468} 469 470# 471# $response = readResponse 472# 473# This subroutine reads and formats an IMAP protocol response from an 474# IMAP server on a specified connection. 475# 476 477sub readResponse { 478 479my $fd = shift; 480 481 exit unless defined $fd; 482 $response = <$fd>; 483 chop $response; 484 $response =~ s/\r//g; 485 push (@response,$response); 486 Log ("<< *** Connection timeout ***") if $conn_timed_out; 487 Log ("<< $response") if $showIMAP; 488 return $response; 489} 490 491sub getMailboxList { 492 493my $user = shift; 494my $conn = shift; 495my @mbxs; 496my @mailboxes; 497 498 # Get a list of the user's mailboxes 499 # 500 if ( $mbxList ) { 501 # The user has supplied a list of mailboxes so only processes 502 # the ones in that list 503 @mbxs = split(/,/, $mbxList); 504 foreach $mbx ( @mbxs ) { 505 trim( *mbx ); 506 push( @mailboxes, $mbx ); 507 } 508 return @mailboxes; 509 } 510 511 if ($debug) { Log("Get list of user's mailboxes",2); } 512 513 sendCommand ($conn, "1 LIST \"\" *"); 514 undef @response; 515 while ( 1 ) { 516 $response = readResponse ($conn); 517 if ( $response =~ /^1 OK/i ) { 518 last; 519 } 520 elsif ( $response !~ /^\*/ ) { 521 Log ("unexpected response: $response"); 522 return 0; 523 } 524 } 525 526 undef @mbxs; 527 528 for $i (0 .. $#response) { 529 $response[$i] =~ s/\s+/ /; 530 if ( $response[$i] =~ /"$/ ) { 531 $response[$i] =~ /\* LIST \((.*)\) "(.+)" "(.+)"/i; 532 $mbx = $3; 533 } else { 534 $response[$i] =~ /\* LIST \((.*)\) "(.+)" (.+)/i; 535 $mbx = $3; 536 } 537 $mbx =~ s/^\s+//; $mbx =~ s/\s+$//; 538 539 if ($response[$i] =~ /NOSELECT/i) { 540 if ($debug) { Log("$mbx is set NOSELECT,skip it",2); } 541 next; 542 } 543 if (($mbx =~ /^\#/) && ($user ne 'anonymous')) { 544 # Skip public mbxs unless we are migrating them 545 next; 546 } 547 if ($mbx =~ /^\./) { 548 # Skip mailboxes starting with a dot 549 next; 550 } 551 push ( @mbxs, $mbx ) if $mbx ne ''; 552 } 553 554 if ( $mbxList ) { 555 # The user has supplied a list of mailboxes so only processes 556 # those 557 @mbxs = split(/,/, $mbxList); 558 } 559 560 return @mbxs; 561} 562 563# getMsgList 564# 565# Get a list of the user's messages in the indicated mailbox on 566# the source host 567# 568sub getMsgList { 569 570my $mailbox = shift; 571my $msgs = shift; 572my $conn = shift; 573my $seen; 574my $empty; 575my $msgnum; 576my $from; 577my $flags; 578 579 @$msgs = (); 580 trim( *mailbox ); 581 sendCommand ($conn, "1 EXAMINE \"$mailbox\""); 582 undef @response; 583 $empty=0; 584 while ( 1 ) { 585 $response = readResponse ( $conn ); 586 if ( $response =~ / 0 EXISTS/i ) { $empty=1; } 587 if ( $response =~ /^1 OK/i ) { 588 # print STDERR "response $response\n"; 589 last; 590 } 591 elsif ( $response !~ /^\*/ ) { 592 Log ("unexpected response: $response"); 593 # print STDERR "Error: $response\n"; 594 return 0; 595 } 596 } 597 598 if ( $empty ) { 599 Log("$mailbox is empty"); 600 return; 601 } 602 603 Log("Fetch the header info") if $debug; 604 605 sendCommand ( $conn, "1 FETCH 1:* (uid flags internaldate body[header.fields (From Date)])"); 606 undef @response; 607 while ( 1 ) { 608 $response = readResponse ( $conn ); 609 return if $conn_timed_out; 610 if ( $response =~ /^1 OK/i ) { 611 last; 612 } elsif ( $response =~ /could not be processed/i ) { 613 Log("Error: response from server: $response"); 614 return; 615 } elsif ( $response =~ /^1 NO|^1 BAD/i ) { 616 return; 617 } 618 } 619 620 $flags = ''; 621 for $i (0 .. $#response) { 622 $seen=0; 623 $_ = $response[$i]; 624 625 last if /OK FETCH complete/; 626 627 if ($response[$i] =~ /FLAGS/) { 628 # Get the list of flags 629 $response[$i] =~ /FLAGS \(([^\)]*)/; 630 $flags = $1; 631 $flags =~ s/\\Recent//; 632 } 633 634 if ( $response[$i] =~ /INTERNALDATE/) { 635 $response[$i] =~ /INTERNALDATE (.+) BODY/; 636 # $response[$i] =~ /INTERNALDATE "(.+)" BODY/; 637 $date = $1; 638 639 $date =~ /"(.+)"/; 640 $date = $1; 641 $date =~ s/"//g; 642 } 643 644 if ( $response[$i] =~ /\* (.+) FETCH/ ) { 645 ($msgnum) = split(/\s+/, $1); 646 } 647 648 if ( $msgnum && $date ) { 649 if ( $unseen ) { 650 push (@$msgs,"$msgnum|$date|$flags") unless $flags =~ /Seen/i; 651 } else { 652 push (@$msgs,"$msgnum|$date|$flags"); 653 } 654 $msgnum = $date = ''; 655 } 656 } 657 658} 659 660# insert_imap_msg 661# 662# This routine inserts an RFC822 message into a user's folder 663# 664sub insert_imap_msg { 665 666my $conn = shift; 667my $mbx = shift; 668my $message = shift; 669my $flags = shift; 670my $date = shift; 671my ($lsn,$lenx); 672 673 $lenx = length($$message); 674 Log(" Inserting message") if $debug; 675 Log("message size $lenx bytes"); 676 677 $date =~ s/\((.+)\)//; 678 $date =~ s/\s+$//g; 679 680 $totalBytes = $totalBytes + $lenx; 681 $totalMsgs++; 682 683 # Create the mailbox unless we have already done so 684 if ($destMbxs{"$mbx"} eq '') { 685 createMbx( $mbx, $conn ); 686 } 687 $destMbxs{"$mbx"} = '1'; 688 689 $flags =~ s/\\Recent//i; 690 $flags =~ s/Unseen//i; 691 692 if ( $date ) { 693 sendCommand ($conn, "1 APPEND \"$mbx\" ($flags) \"$date\" \{$lenx\}"); 694 } else { 695 sendCommand ($conn, "1 APPEND \"$mbx\" ($flags) \{$lenx\}"); 696 } 697 698 $response = readResponse ($conn); 699 if ($conn_timed_out) { 700 Log ("unexpected response timeout appending message"); 701 push(@errors,"Error appending message to $mbx for $user"); 702 return 0; 703 } 704 705 if ( $response !~ /^\+/ ) { 706 Log ("unexpected APPEND response: >$response<"); 707 # next; 708 push(@errors,"Error appending message to $mbx for $user"); 709 return 0; 710 } 711 712 print $conn "$$message\r\n"; 713 714 undef @response; 715 while ( 1 ) { 716 $response = readResponse ($conn); 717 if ( $response =~ /^1 OK/i ) { 718 last; 719 } 720 elsif ( $response !~ /^\*/ ) { 721 Log ("Unexpected APPEND response: >$response<"); 722 # next; 723 return 0; 724 } 725 } 726 727 return 1; 728} 729 730sub get_maildir_folders { 731 732my $userpath = shift; 733my $folders = shift; 734 735 # Get a list of the user's folders 736 737 %$folders = (); 738 739 if ( $mbxList ) { 740 # The user has supplied a list of mailboxes 741 foreach $mbx ( split(/,/, $mbxList ) ) { 742 $$folders{"$mbx"} = $userpath . '/.' . $mbx; 743 } 744 return; 745 } 746 747 opendir D, $userpath; 748 my @files = readdir( D ); 749 closedir D; 750 751 $$folders{'INBOX'} = $userpath; 752 foreach $fn ( @files ) { 753 next if $fn eq '.'; 754 next if $fn eq '..'; 755 next unless $fn =~ /^\./; 756 my $fname = $fn; 757 $fname =~ s/\./\//; 758 $fname =~ s/^\///; 759 $$folders{"$fname"} = "$userpath/$fn"; 760 } 761 762} 763 764sub get_maildir_msgs { 765 766my $path = shift; 767my $msgs = shift; 768my @subdirs = qw( tmp cur new ); 769 770 @$msgs = (); 771 foreach $subdir ( @subdirs ) { 772 opendir D, "$path/$subdir"; 773 my @files = readdir( D ); 774 closedir D; 775 776 foreach $fn ( @files ) { 777 next if $fn =~ /^\./; 778 my $msgfn = "$path/$subdir/$fn"; 779 push( @$msgs, $msgfn ); 780 } 781 } 782 783} 784 785sub imap_message_exists { 786 787my $msgid = shift; 788my $conn = shift; 789my $msgnum; 790my $loops; 791 792 # Search a mailbox on the server for a message by its msgid. 793 794 Log(" Search for $msgid") if $debug; 795 sendCommand ( $conn, "1 SEARCH header Message-Id \"$msgid\""); 796 while (1) { 797 $response = readResponse ($conn); 798 if ( $response =~ /\* SEARCH /i ) { 799 ($dmy, $msgnum) = split(/\* SEARCH /i, $response); 800 ($msgnum) = split(/ /, $msgnum); 801 } 802 803 last if $response =~ /^1 OK|^1 NO|^1 BAD/; 804 last if $response =~ /complete/i; 805 806 last if $loops++ > 10; 807 } 808 809 if ( $debug ) { 810 Log("$msgid was not found") unless $msgnum; 811 } 812 813 return $msgnum; 814} 815 816sub fix_date { 817 818my $date = shift; 819 820 # Try to make the date acceptable to IMAP 821 822 return if $$date eq ''; 823 fix_ts( $date ); 824 825 $$date =~ s/\((.+)\)$//; 826 $$date =~ s/\s+$//g; 827 828 if ( $$date =~ /\s*,\s*/ ) { 829 ($dow,$$date) = split(/\s*,\s*/, $$date); 830 } 831 $$date =~ s/ /-/; 832 $$date =~ s/ /-/; 833 834 return; 835 836 my @terms = split(/\s+/, $$date); 837 838 if ( $terms[0] =~ /(.+),/ ) { 839 my $dow = $1; 840 if ( length( $dow ) > 3 ) { 841 # Day of week can't be more than 3 chars 842 my $DOW = substr($dow,0,3); 843 $$date =~ s/$dow/$DOW/; 844 } 845 } 846 847 if ( $terms[1] =~ /jan|feb|mar|apr|may|jun|jul|aug|sep|oct|nov|dec/i ) { 848 # The month and day are swapped. 849 my $temp = $terms[1]; 850 $terms[1] = $terms[2]; 851 $terms[2] = $temp; 852 } 853 854 if ( $terms[5] =~ /\((.+)\)/ ) { 855 # The date is missing the TZ offset 856 $terms[5] = "+0000 ($1)"; 857 } 858 859 if ( $terms[5] =~ /"(.+)"/ ) { 860 # The TZ code has quotes instead of parens 861 $terms[5] =~ s/"/\(/; 862 $terms[5] =~ s/"/\)/; 863 $terms[5] = "+0000 $terms[5]"; 864 } 865 866 if ( $terms[5] =~ /-[0-9]-[0-9][0-9]/ ) { 867 # Lots of dates are like '-0-500' 868 $terms[5] =~ s/-//g; 869 $terms[5] = '-' . $terms[5]; 870 } 871 872 if ( $terms[5] eq '-0-100' ) { 873 # Don't know what this is supposed to mean 874 $terms[5] = "+0000"; 875 } 876 877 if ( $terms[5] eq '00800' ) { 878 $terms[5] = "+0800"; 879 } 880 881 if ( $terms[5] eq '-' ) { 882 $terms[5] .= $terms[6]; 883 $terms[5] =~ s/\s+//g; 884 $terms[6] = ''; 885 } 886 if ( $terms[4] =~ /\./ ) { 887 $terms[4] =~ s/\./:/g; 888 } 889 890 if ( $terms[5] =~ /[a-zA-Z]/ ) { 891 $terms[5] = "-0000 ($terms[5])" unless $terms[5] eq 'UT'; 892 } 893 894 $$date = join( " ", @terms ); 895 896} 897 898