[Mew-dist 05486] Re: About imstore
Nobuhiro Tsuchie
tsuchie at example.com
1998年 7月 13日 (月) 00:20:22 JST
いつもお世話になっています。土江と申します。
>>>>> On Fri, 10 Jul 1998 00:18:27 +0900
>>>>> mokkun at example.com(Akihiro Motoki) said:
元木> Mew では refile や delete を(IMを利用せずに)自分で行うので、
元木> そっちでもインターフェースが必要である。
まだ対応してません。どのファイル辺りに関連処理があるのでしょうか？
私も Emacs Lisp は、あまり詳しくないので、
どなたかヒントを貰えないでしょうか？
元木> ・pack や sort を行ったときはどうするのか？
元木> (これが一番むずかしいかも。IMでするのかMewでするか、それとも無視？)
impack と imsort 用の各種パッチと pack.sbr を新規作成しました。添付します。
pack.sbr を ~/.im に置き、~/.im/Config に PackSbr=pack.sbr と書いて下さい。
これで、IM への実装は完璧でしょうか？ なにしろ、使ったことの無い機能が
たくさんあるので、他にも対応が必要な箇所がありそうな気がします。
また、perl のソースをいじったのは、この Subject の件が初めてだったのですが、
結構、簡単に出来てしまったので、拍子抜けしてしまいました。
これから、perl にはまってしまいそうです。
今回の pack.sbr は、World Cup の決勝戦までの暇潰しに丁度いいかと
思っていたのに...
あと４時間、Mew をいじるか、寝るか、どうしよう！
元木> そういえば、マークの保存の話がありましたね。どうなったんでしょう。
"マークの保存" とは、何ですか？
土江 伸宏
tsuchie at example.com
-------------- next part --------------
# -*-Perl-*-
# A user customizable subroutine for impack and imsort.
# 'pack_sub' is called if "PackSbr=pack.sbr" is specified in your "Config".
%hash = ();
sub pack_sub ($$$) {
my ($folder, $from, $to) = @_;
my $dir = expand_path($folder);
my ($name, $val);
open(SEQ, "$dir/.mh_sequences") || return;
while (<SEQ>) {
chomp;
($name, $val) = split(': ');
$hash{$name} = " $val";
}
close(SEQ);
if (defined($hash{'unseen'})) {
$exist = 0;
@arts = split(' ', $hash{'unseen'});
$hash{'unseen'} = "";
foreach $art (@arts) {
if ($art =~ /[0-9]*-[0-9]*/) {
($pre, $post) = split(/-/,$art);
} else {
$pre = $art;
$post = $art;
}
$exist = 1 if ($from >= $pre && $from <= $post);
if ($pre == $post) {
$hash{'unseen'} .= " $pre" if ($from != $pre);
} else {
if ($from == $pre) {
$from1 = $from + 1;
if ($from1 == $post) {
$hash{'unseen'} .= " $post";
} else {
$hash{'unseen'} .= " $from1-$post";
}
} elsif ($from == $post) {
$from1 = $from - 1;
if ($pre == $from1) {
$hash{'unseen'} .= " $pre";
} else {
$hash{'unseen'} .= " $pre-$from1";
}
} elsif ($from > $pre && $from < $post) {
$from1 = $from - 1;
$from2 = $from + 1;
if ($pre == $from1 && $from2 == $post) {
$hash{'unseen'} .= " $pre $post";
} elsif ($pre == $from1) {
$hash{'unseen'} .= " $pre $from2-$post";
} elsif ($from2 == $post) {
$hash{'unseen'} .= " $pre-$from1 $post";
} else {
$hash{'unseen'} .= " $pre-$from1 $from2-$post";
}
} else {
$hash{'unseen'} .= " $pre-$post";
}
}
}
if ($exist) {
$hash{'unseen'} .= " $to";
@arts = split(' ', $hash{'unseen'});
if (@arts >= 2) {
$prepost = 0;
foreach (sort { $a cmp $b } @arts) {
if (/[0-9]*-[0-9]*/) {
($pre, $post) = split(/-/);
} else {
$pre = $_;
$post = $_;
}
if ($prepost + 1 == $pre) {
if (!$prepost) {
$hash{'unseen'} = " $pre";
$prepre = $pre;
}
} else {
if (!$prepost) {
$hash{'unseen'} = " $pre";
} else {
if ($prepre != $prepost) {
$hash{'unseen'} .= "-$prepost $pre";
} else {
$hash{'unseen'} .= " $pre";
}
}
$prepre = $pre;
}
$prepost = $post;
}
$hash{'unseen'} .= "-$post" if ($prepre != $post);
}
open(SEQ, ">$dir/.mh_sequences");
foreach (keys %hash) {
print SEQ "$_:$hash{$_}\n";
}
close (SEQ);
}
}
}
1;
-------------- next part --------------
*** im-94/impack.in.bak Mon Jun 8 11:17:39 1998
--- im-94/impack.in Sun Jul 12 23:13:21 1998
***************
*** 27,39 ****
## Require packages
##
use IM::Config;
use IM::Folder;
use IM::File;
use IM::Util;
use integer;
use strict;
! use vars qw($Prog $EXPLANATION @OptConfig
$opt_src $opt_noharm $opt_verbose $opt_debug $opt_help);
##
--- 27,41 ----
## Require packages
##
+ use File::Basename;
use IM::Config;
use IM::Folder;
use IM::File;
+ use IM::MsgStore;
use IM::Util;
use integer;
use strict;
! use vars qw($Prog $EXPLANATION @OptConfig $First $Last
$opt_src $opt_noharm $opt_verbose $opt_debug $opt_help);
##
***************
*** 80,86 ****
sub impack ($) {
my $folder = shift;
my $msg = 1;
! my $dst;
chk_folder_existance($folder); # not return in case false.
--- 82,88 ----
sub impack ($) {
my $folder = shift;
my $msg = 1;
! my ($dst, $stat);
chk_folder_existance($folder); # not return in case false.
***************
*** 93,99 ****
$dst = $_;
$dst =~ s|[^/]+$|$msg++|e;
if ($_ ne $dst){
! im_rename($_, $dst) || die $@; # XXX
}
}
--- 95,106 ----
$dst = $_;
$dst =~ s|[^/]+$|$msg++|e;
if ($_ ne $dst){
! $stat = im_rename($_, $dst);
! if ($stat) {
! &exec_packsbrfile($opt_src, basename($_), basename($dst));
! } else {
! die $@;
! }
}
}
-------------- next part --------------
*** im-94/imsort.in.bak Mon Jun 8 11:17:45 1998
--- im-94/imsort.in Sun Jul 12 23:13:27 1998
***************
*** 27,35 ****
--- 27,37 ----
## Require packages
##
+ use File::Basename;
use IM::Config;
use IM::Folder;
use IM::File;
+ use IM::MsgStore;
use IM::Util;
use integer;
use strict;
***************
*** 114,120 ****
sub imsort ($$$$) {
my ($src, $msgs, $mode, $field) = @_;
! my ($i, $path, $from, $to, $tmp, @msg_paths, @sorted_index);
my @param = ();
my $HOLE_PATH = get_impath($src, 'new');
--- 116,122 ----
sub imsort ($$$$) {
my ($src, $msgs, $mode, $field) = @_;
! my ($i, $path, $from, $to, $tmp, $stat, @msg_paths, @sorted_index);
my @param = ();
my $HOLE_PATH = get_impath($src, 'new');
***************
*** 148,154 ****
}
$sorted_index[$to] = -1;
! im_rename($msg_paths[$from], $msg_paths[$to]) || die;
} while ($to = $from) != $tmp;
$#msg_paths = $#sorted_index = $tmp - 1;
--- 150,162 ----
}
$sorted_index[$to] = -1;
! $stat = im_rename($msg_paths[$from], $msg_paths[$to]);
! if ($stat) {
! &exec_packsbrfile($opt_src, basename($msg_paths[$from]),
! basename($msg_paths[$to]));
! } else {
! die;
! }
} while ($to = $from) != $tmp;
$#msg_paths = $#sorted_index = $tmp - 1;
-------------- next part --------------
*** im-94/IM.in/Config.pm.in.bak Wed May 6 15:10:53 1998
--- im-94/IM.in/Config.pm.in Sun Jul 12 23:07:42 1998
***************
*** 41,48 ****
folder_mode msg_mode allowcrlf no_sync
aliases_file context_file
address addresses_regex
! msgdbfile msgdbtype getsbrfile scansbrfile petnamefile
! mbox_style
nntpservers nntphistoryfile
popaccount pophistoryfile imapaccount httpproxy noproxy
usepwagent pwagentport usepwfiles pwfiles
--- 41,48 ----
folder_mode msg_mode allowcrlf no_sync
aliases_file context_file
address addresses_regex
! msgdbfile msgdbtype getsbrfile movesbrfile packsbrfile scansbrfile
! petnamefile mbox_style
nntpservers nntphistoryfile
popaccount pophistoryfile imapaccount httpproxy noproxy
usepwagent pwagentport usepwfiles pwfiles
***************
*** 105,110 ****
--- 105,112 ----
'msgdbtype;s;;MsgDBType' => 'Message database type',
'petnamefile;s;;PetNameFile' => 'PetName file',
'getsbr;s;;GetSbrFile' => 'Get hook subroutine script',
+ 'movesbr;s;;MoveSbrFile' => 'Move hook subroutine script',
+ 'packsbr;s;;PackSbrFile' => 'Pack hook subroutine script',
'scansbr;s;;ScanSbrFile' => 'Scan hook subroutine script',
'mboxstyle;s;;MBoxStyle' => 'Style of local MBox format',
'nntpservers;s;;NNTPservers' => 'List of NNTP servers',
***************
*** 763,768 ****
--- 765,778 ----
sub getsbrfile () {
return &expand_path($GetSbrFile);
+ }
+
+ sub movesbrfile () {
+ return &expand_path($MoveSbrFile);
+ }
+
+ sub packsbrfile () {
+ return &expand_path($PackSbrFile);
}
sub scansbrfile () {
-------------- next part --------------
*** im-94/IM.in/MsgStore.pm.in.bak Fri May 1 18:56:09 1998
--- im-94/IM.in/MsgStore.pm.in Sun Jul 12 23:07:59 1998
***************
*** 21,27 ****
require Exporter;
use Fcntl;
! use IM::Config qw(getsbrfile msg_mode msgdbfile expand_path no_sync);
use IM::Util;
use IM::Folder qw(message_number message_name create_folder touch_folder);
use IM::Header qw(gen_date);
--- 21,28 ----
require Exporter;
use Fcntl;
! use IM::Config qw(getsbrfile movesbrfile packsbrfile msg_mode msgdbfile
! expand_path no_sync);
use IM::Util;
use IM::Folder qw(message_number message_name create_folder touch_folder);
use IM::Header qw(gen_date);
***************
*** 30,36 ****
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
! @EXPORT = qw(store_message exec_getsbrfile open_fcc excl_create fsync);
=head1 NAME
--- 31,38 ----
use vars qw(@ISA @EXPORT);
@ISA = qw(Exporter);
! @EXPORT = qw(store_message exec_getsbrfile exec_movesbrfile exec_packsbrfile
! open_fcc excl_create fsync);
=head1 NAME
***************
*** 215,220 ****
--- 217,270 ----
if ($@) {
im_warn("Form seems to be wrong.\nPerl error message is: $@");
}
+ }
+ return;
+ }
+
+ sub exec_movesbrfile ($@) {
+ my ($src, @msgs) = @_;
+ my $move_hook = movesbrfile();
+ if ($move_hook) {
+ if ($main::INSECURE) {
+ im_warn("Sorry, MoveSbr is ignored for SUID root script\n");
+ return;
+ }
+ if ($move_hook =~ /^(\S+)$/) {
+ $move_hook = $1; # to pass through taint check
+ if (-f $move_hook) {
+ require $move_hook;
+ } else {
+ im_err("move subroutine file $move_hook not found.\n");
+ }
+ }
+ eval { &move_sub($src, @msgs); };
+ if ($@) {
+ im_warn("Form seems to be wrong.\nPerl error message is: $@");
+ }
+ }
+ return;
+ }
+
+ sub exec_packsbrfile ($$$) {
+ my ($src, $from, $to) = @_;
+ my $pack_hook = packsbrfile();
+ if ($pack_hook) {
+ if ($main::INSECURE) {
+ im_warn("Sorry, MoveSbr is ignored for SUID root script\n");
+ return;
+ }
+ if ($pack_hook =~ /^(\S+)$/) {
+ $pack_hook = $1; # to pass through taint check
+ if (-f $pack_hook) {
+ require $pack_hook;
+ } else {
+ im_err("pack subroutine file $pack_hook not found.\n");
+ }
+ }
+ eval { &pack_sub($src, $from, $to); };
+ if ($@) {
+ im_warn("Form seems to be wrong.\nPerl error message is: $@");
+ }
}
return;
}
Mew-dist メーリングリストの案内