[Mew-dist 1180] Re: imsort + patch (Re: IM official patch 1)

[ukai at example.com]

From: SAKAI Kiyotaka <ksakai at example.com>
Subject: [Mew-dist 1176] Re: imsort + patch (Re: IM official patch 1)
Date: Thu, 03 Jul 1997 13:27:59 +0900

> > これ Alpha testing だし、C が必要みたいですが、それでも
> > いいんでしょうか?
> 
> 個人的には、perl で標準に添付されているものであれば使う価値はあります
> が、そうでなければプラットホーム間の互換性も心配になりますし、ユーザー
> にとってはわざわざインストールするのは手間ですので、自前で用意した方が
> いいと思います。option で使うかどうかを選択できるようにするのであれば
> 問題ないと思いますが、そこまでやるのも…、という気もします。

そうですねぇ。とりあえず RFC822 と INN の parsedate(3)あたりが
解釈できればいいのでしょうか?

> あと、imsort ですが、欲を言えば contrib/mew-sort.el で行っている機能を
> 実現するために、sortm の -datefiled, -textfield に相当する機能があると
> 便利だと思います。

これはそんなに難しくなかったので作ってみました(^^;

 --textfield は -textfield -limit 0 と同じように sort (text major, date minor)

 --textfield と --datefield を同時に指定したら datefield も
 変更できて かつ text major, date minor で sort

 --textfield=subject の時は Re: をけずって比較

するはずです。これでどうでしょうか?

date major, text minor は date が秒単位で比較なので
意味なさそう(なのでなし)。 sortmの -limit もいまいちよくわかんないし…

あと Date: は $Header{'date'}じゃなくて $Header{'date:'}なので
([Mew-dist 1148]) 指定するなら --datefield=date: じゃないと駄目
なので注意

> # mew-dist の配送が遅い…。
# 自分のが3時間かかってかえってきた…

-- 
鵜飼文敏
-------------- next part --------------
#! @im_cv_path_perl@
# Copyright (c) 1997 UKAI Fumitoshi
#

my $VERSION = "imsort @im_cv_version@";
$Prog = 'imsort';

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

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

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

@OptConfig = (
      'src;F@;;' => 'Message source',
      'datefield;s;;' => 'Sort by specified field, as RFC822 date'
			. "\n\t\t(default: \"date:\")",
      'textfield;s;;' => 'Sort by specified field' 
	                . "\n\t\t(default: \"subject\")",
      'noharm;b;;' => 'No sorting.  Show what will happen.',
      'verbose;b;;' => 'set verbose mode',
      '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);

my $keyhook;
my $textfield;
my $datefield = 'date:';
my $sort_method = \&sortbydate;

if (defined($opt_datefield)) {
    $datefield = $opt_datefield || 'date:';
    $sort_method = \&sortbydate;
}
if (defined($opt_textfield)) {
    $textfield = $opt_textfield || 'subject';
    if ($textfield eq 'subject') {
	$keyhook = 's/re:\s+//i';
    }
    $sort_method = \&sortbytext;
}

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($datefield, $textfield, $keyhook, 
		     $sort_method, $_, @ARGV);
    } else {
	im_die("doesn't support $opt_src\n");
    }
    exit $EXIT_SUCCESS;
}

sub sortbynum {
    $sortkey{$a} <=> $sortkey{$b} or $msgdate{$a} <=> $msgdate{$b};
}

sub sortbytext {
    $sortkey{$a} cmp $sortkey{$b} or $msgdate{$a} <=> $msgdate{$b};
}

sub sortbydate {
    $msgdate{$a} <=> $msgdate{$b};
}

sub local_files {
    my ($datefield, $textfield, $keyhook, $method, $folder, @arg) = @_;
    my (%Head) = ();
    my ($num);
    my (@list, @sorted) = ();
    local (%sortkey, %msgdate) = ();	# XXX
    $datefield = 'date:' unless defined($datefield);

    foreach $num (get_message_paths($folder, @arg)) {
	if (-f $num) {
	    %Head = &get_header($num);
	    if (defined($textfield)) {
		$_ = $Head{$textfield};
		if (defined($keyhook)) {
		    eval($keyhook);
		}
		$sortkey{$num} = $_;
	    }
	    ;# always 
	    $msgdate{$num} = datetm($Head{$datefield});
	    push(@list, $num);
	}
    }
    $method = \&sortbytext unless defined($method);

    @sorted = sort {&{$method}} @list;
    &renumber_messages(\@sorted, \@list);
}

;# renumber @{$cur} to @{$new}
sub renumber_messages {
    my ($cur, $new) = @_;
    my (%tmp);
    my ($n);
    
    if ($#{$cur} != $#{$new}) {
	im_die("array size not match $#{$cur} != $#{$new}\n");
    }

    foreach (@{$cur}) {
	$tmp{$_} = $_;
    }

    ;# cur[$n]: current nth filename 
    ;# new[$n]: desired nth filename 
    ;# tmp{$num}: actual current $num's filename

    for ($n = 0; $n <= $#{$cur}; $n++) {
	if ($cur->[$n] ne $new->[$n]) {
	    ;# $cur->[$n] should be renamed to $new->[$n]
	    print "$cur->[$n] => $new->[$n]\n" if $opt_verbose;

	    if (defined($tmp{$new->[$n]})) {
		# but $new->[$n] still exits, so save as .tmp
		# record this file is now .tmp
		$tmp{$new->[$n]} .= '.tmp';
		&renamefile($new->[$n], $tmp{$new->[$n]});
	    }
	    # at this point, $new->[$n] is no longer exists (already moved)
	    # or move to .tmp now, so we can rename $cur->[$n] to $new->[$n]

	    &renamefile($tmp{$cur->[$n]}, $new->[$n]);
	    # mark $cur->[$n] is done, moved to $new->[$n]
	    delete $tmp{$cur->[$n]};
	}
    }
}

sub renamefile {
    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;
}
-------------- next part --------------
## Date.pm
##  Copyright (c) 1997 UKAI Fumitoshi
## 
my $VERSION = "IM:Date.pm @im_cv_version@";

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),
         'JST' => (9 * 60),  # non-standard, but used by old(?) mailer
 );

$zonepat = join('|', keys %zone, 'A-IK-Z', '[-+]\d{4}');
	
sub datetm {
    my ($d) = @_;
    my $date = {};
    $d =~ s/\(.*?\)/ /g;		# remove comments
    $d =~ s/\n/ /g;
    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+(\S*)\s*$/i) {
	$date->{'mday'} = $1;
	$date->{'mon'} = &mstr2num($2);
	$date->{'year'} = $3;
	$date->{'hours'} = $4;
	$date->{'min'} = $5;
	$date->{'sec'} = $6;
	my $tz = $7;
	if ($tz =~ /$zonepat/) {
	    $date->{'tzoffset'} = &tz2num($tz);
	} else {
	    $date->{'tzoffset'} = 0; # XXX
	}
    } 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 = uc($tzstr);

    if (defined($zone{$tzstr})) {
	return $zone{$tzstr};
    } elsif ($tzstr =~ /A-IK-Z/) {
	;# draft-ietf-drums-msg-fmt-02.txt says
	;# mil timezones SHOULD all be considered equivalent to "-0000".
	return 0; 

	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;
    }
    ;# draft-ietf-drums-msg-fmt-02.txt
    ;# Any unknown time zone specification SHOULD be considered equivalent
    ;# too "-0000".
    return 0;
}

1;