[Mew-dist 1143] imsort-alpha (Re: Mew 1.85 & IM 40 beta release)

[ukai at example.com]

From: SAKAI Kiyotaka <ksakai at example.com>
Subject: [Mew-dist 1137] Re: Mew 1.85 & IM 40 beta release
Date: Tue, 01 Jul 1997 14:10:37 +0900

> そのため、sort 機能を使うときに限り MH (の sortm) が必要です。
> なお、perl 版 sortm の contribute は歓迎だと思います。

現実逃避に書いてみました。Date: 見てsortするだけの
いい加減なやつです(^^;

# バグってたらごめんなさい。

-- 
鵜飼文敏
-------------- next part --------------
--- Scan.pm.orig	Tue Jul  1 20:27:30 1997
+++ Scan.pm	Tue Jul  1 20:59:57 1997
@@ -222,6 +222,9 @@
 	##
 	## Date
 	##
+	## XXX: save original date
+	$Head{'date:'} = $Head{'date'};
+
 	my ($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) =
 		localtime((stat($path))[9]);
 	my $stamp = sprintf "%s%d/%s%d*", 
-------------- next part --------------
## Date.pm
##  Copyright (c) 1997 UKAI Fumitoshi
## 
my $VERSION = "IM:Date.pm version 970701";

package IM::Date;
require Exporter;

use IM::Config;
use IM::Debug;
use IM::ErrorReport;

use Time::Local;

@ISA = qw(Exporter);
@EXPORT = qw(datetm);

=head1 NAME

Date - RFC822 style date parser

=head1 SYNOPSIS

  use IM::Date;

  $t = datetm($datefield);

  ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
	localtime($t);

=head1 DESCRIPTION

   datetm returns a time as returned by the time function,
   the number of non-leap seconds since whatever time the
   system considers to be the epoch (that's 00:00:00 UTC, January 1,
   1970.)

=cut

@dstrs = ('mon', 'tue', 'wed', 'thu', 'fri', 'sat', 'sun');
$dstrpat = join('|', @dstrs);
@mstrs = ('jan', 'feb', 'mar', 'apr', 'may', 'jun', 
	  'jul', 'aug', 'sep', 'oct', 'nov', 'dec');
$mstrpat = join('|', @mstrs);

%zone = (
	 'ut' => 0,
	 'gmt' => 0,
	 'est' => (-5 * 60),
	 'edt' => (-4 * 60),
	 'cst' => (-6 * 60),
	 'cdt' => (-5 * 60),
	 'mst' => (-7 * 60),
	 'mdt' => (-6 * 60),
	 'pst' => (-8 * 60),
	 'pdt' => (-7 * 60)
 );

$zonepat = join('|', keys %zone, 'a' .. 'z', '[-+]\d{4}');
	
sub datetm {
    my ($d) = @_;
    my $date = {};
    if ($d =~ s/^\s*($dstrpat)\s*,\s*//i) {
	$date->{'wday'} = $1;
    }

    if ($d =~ /^\s*(\d{1,2})\s+($mstrpat)\s+(\d{2,4})\s+(\d{2}):(\d{2}):(\d{2})\s+($zonepat)/i) {
	$date->{'mday'} = $1;
	$date->{'mon'} = &mstr2num($2);
	$date->{'year'} = $3;
	$date->{'hours'} = $4;
	$date->{'min'} = $5;
	$date->{'sec'} = $6;
	$date->{'tzoffset'} = &tz2num($7);
    } else {
	&error_log(0, "illegal format for date: $d\n");
	return 0;
    }
    return timegm($date->{'sec'}, $date->{'min'}, $date->{'hours'},
		  $date->{'mday'}, $date->{'mon'}-1, $date->{'year'})
	- ($date->{'tzoffset'} * 60);
}

sub mstr2num {
    my ($mstr) = @_;
    my ($m) = 1;
    foreach (@mstrs) {
	if ($mstr =~ /$_/i) {
	    return $m;
	}
	++$m;
    }
    return 0;			# /* illegal? */
}

sub tz2num {
    my ($tzstr) = @_;
    
    $tzstr =~ tr/[A-Z]/[a-z]/;

    if (defined($zone{$tzstr})) {
	return $zone{$tzstr};
    } elsif ($tzstr =~ /a-z/i) {
	my ($m) = ord($tzstr);

	if ($m == ord('z')) {
	    return 0;
	} elsif ($m < ord('j')) {
	    return -1 * ($m - ord('a') + 1) * 60;
	} elsif ($m < ord('m')) {
	    return -1 * ($m - ord('a')) * 60;
	} else {
	    return ($m - ord('m')) * 60;
	}
    } elsif ($tzstr =~ /([+-])(\d{2})(\d{2})/) {
	my $sign = 1;
	$sign = ($1 eq '+') ? 1 : -1;
	return $sign * $2 * 60 + $3;
    }
    return 0;			# ??
}

1;
	
-------------- next part --------------
#!/usr/local/bin/perl5
# Copyright (c) 1997 UKAI Fumitoshi
#

my $VERSION = "imsort version 970701";
$Prog = 'imsort';

use IM::Config;
use IM::Scan;
use IM::Stdio;
use IM::Date;

$EXPLANATION = "
$Prog :: Internet Message Sort
$VERSION

Usage :: $Prog [options] [+folder] [range]
";

@OptConfig = (
      'src;F@;;' => 'Message source',
      'noharm;b;;' => 'No sorting.  Show waht will happen.',
      'help;b;;' => 'Show this message',
);

init_opt(\@OptConfig);
read_env(\@EnvConfig);
read_cfg();
read_opt(\@ARGV);
help($EXPLANATION) && exit $EXIT_SUCCESS if ($opt_help);

@ARGV = ('all') if $#ARGV == -1;
@opt_src = &uniq(@opt_src);

if (scalar(@opt_src) < 1) {
    im_die("must specify one or more folders.\n");
} else {
    if (scalar(@opt_src) != 1) {
	im_die("must specify just one folder.\n");
    }
    $_ = $opt_src[0];
    if (/^[+=]/) {
	require IM::Folder && import IM::Folder;
	&local_files($_, @ARGV);
    } else {
	im_die("doesn't support $opt_src\n");
    }
    exit $EXIT_SUCCESS;
}

sub sortbytime {
    my ($l, $a, $b) = @_;
    my ($r);

    $r = $l->{$a}->{t} <=> $l->{$b}->{t};
    return $r;
}

sub local_files {
    my $folder = shift;
    my @arg = @_;
    my %Head = ();
    my $num, $n;
    my (%List, @cur, @sorted) = ();

    $n = 0;
    foreach $num (get_message_paths($folder, @arg)) {
	if (-f $num) {
	    %Head = &get_header($num);
	    $List{$num} = {
		't' => datetm($Head{'date:'}),
		'n' => $n,
		'num' => $num
	    };
	    push(@cur, $num);
	    $n++;
	    # print "$num $Head{'date:'} $Head{'date'}\n";
	}
    }

    @sorted = sort {sortbytime(\%List, $a, $b)} keys %List;

    ;# cur[$n]: nth filename in current order
    ;# sorted[$n]: nth filename in sorted order
    ;# List{$num}->{num}: actual current $num's filename

    for ($n = 0; $n <= $#sorted; $n++) {
	if ($cur[$n] ne $sorted[$n]) {

	    if (defined($List{$cur[$n]}->{num})) {
		# already exits, so save as .orig
		&swapfile($cur[$n], "$cur[$n].orig");
		# record this file is now .orig
		$List{$cur[$n]}->{num} .= '.orig';
	    }
	    # at this point, $cur[$n] is no longer exists (already moved)
	    # or move to .orig now.

	    &swapfile($List{$sorted[$n]}->{num}, $cur[$n]);
	    # mark $sorted[$n] is done, moved to $cur[$n]
	    undef $List{$sorted[$n]}->{num};
	}
    }
}

sub swapfile {
    my ($a, $b) = @_;

    if ($opt_noharm) {
	print "mv $a $b\n";
    } else {
	rename($a, $b) || die;
    }
}

sub uniq {
    my @array = @_;
    my %hash;

    foreach (@array) {
	$hash{$_} = $_;
    }
    return keys %hash;
}