#!/usr/local/bin/perl
# $Id: clean.perl,v 1.14 2002/08/03 00:05:39 tsuchiya Exp $

# clean.perl -- 指定されたディレクトリに存在する不要なファイルを削除す
#               るスクリプト

# 利用及び再配布の際は、GNU 一般公用許諾書のバージョン2以降の適当なバー
# ジョンにしたがって下さい。
# このスクリプトは有益であることを目的として作成されていますが、無保証
# です。このスクリプトによって生じたいかなる損害についても、作者は責任
# を負いかねます。


require 5.000;
use File::Find;
use File::Basename qw/ basename dirname /;
use strict;
use vars qw/ @ExceptDir @ExceptFile $MailDir $GnusDir $W3mDir $W3mmeeDir
 $CRON $FORCE $SILENT $DEBUG @DIR @FILES /;


#================================================================================
#		引数の解析
#================================================================================
&parse( @ARGV );
unless( $CRON ){
    unless( @DIR ){
	# 探索すべきディレクトリの指定が欠けている場合
	if( $ENV{'CLEANOPT'} ){
	    my @arg;
	    my $str = $ENV{'CLEANOPT'} . ' ';
	    # 環境変数の文字列中に含まれている single quote および double quote を処理する
	    while( $str =~ s/^((?:\"(?:\\\"|[^\"])*?\"|\'.*?\'|\\\"|\\\'|[^\"\'])*?)\s+// ){ #"
		my( $x, $y, $z );
		$x = $1;
		while( $x ){
		    if( $x =~ s/^\"((?:\\\"|[^\"])*?)\"// ){ #"
			( $y = $1 ) =~ s/\\([\"\'])/$1/g; #"
			$z .= $y;
		    } elsif( $x =~ s/^\'(.*?)\'// ){
			$z .= $1;
		    } else {
			$x =~ s/^((?:\\\"|\\\'|[^\"\'])*)//; #"
			( $y = $1 ) =~ s/\\([\"\'])/$1/g; #"
			$z .= $y;
		    }
		}
		push( @arg, $z ) if $z;
	    }
	    &parse( @arg );
	} else {
	    push( @DIR, $ENV{'HOME'} );
	}
    }
    $MailDir   = $ENV{'HOME'}."/Mail" unless $MailDir;
    $GnusDir   = $ENV{'HOME'}."/Mail" unless $GnusDir;
    $W3mDir    = $ENV{'HOME'}."/.w3m" unless $W3mDir;
    $W3mmeeDir = $ENV{'HOME'}."/.w3mmee" unless $W3mmeeDir;
}


# 引数の解析を行う関数
sub parse {
    my( @argv ) = @_;
    while ( @argv ) {
	$_ = shift @argv;
	if( /^-(?:n|-debug)$/ ) {
	    $DEBUG=1;
	} elsif ( /^(-f|--force)$/ ) {
	    $FORCE=1;
	} elsif ( /^-(?:q|-quiet)$/ ) {
	    $SILENT=1;
	} elsif ( /^-(?:c|-cron)$/ ) {
	    $CRON=1;
	    $FORCE=1;
	    $SILENT=1;
	} elsif ( /^-(?:e|-exclude-file)$/ ) {
	    if ( @argv >= 1 ) {
		push( @ExceptFile, shift @argv );
	    } else {
		&usage;
	    }
	} elsif ( /^-(?:E|-exclude-dir)$/ ) {
	    if ( @argv >= 1 ) {
		push( @ExceptDir, shift @argv );
	    } else {
		&usage;
	    }
	} elsif ( /^-(?:m|-mail-dir)$/ ) {
	    if (( @argv >= 1 )&&( ! $MailDir )) {
		$MailDir = shift @argv;
	    } else {
		&usage;
	    }
	} elsif ( /^-(?:g|-gnus-dir)$/ ) {
	    if (( @argv >= 1 )&&( ! $GnusDir )) {
		$GnusDir = shift @argv;
	    } else {
		&usage;
	    }
	} elsif ( /^-(?:w|-w3m-dir)$/ ) {
	    if (( @argv >= 1 )&&( ! $W3mDir )) {
		$W3mDir = shift @argv;
	    } else {
		&usage;
	    }
	} elsif ( /^-(?:W|-w3mmee-dir)$/ ) {
	    if (( @argv >= 1 )&&( ! $W3mmeeDir )) {
		$W3mmeeDir = shift @argv;
	    } else {
		&usage;
	    }
	} elsif ( /^-(?:v|-version)$/ ) {
	    print STDERR sprintf( "%s %d.%02d\n", $0=~m%([^/]*)$%, q$Revision: 1.14 $=~/(\d+)\.(\d+)/ );
	    exit 1;
	} elsif ( /^-(?:\?|h|-help)$/ ) {
	    &usage;
	} elsif ( -d $_ ) {
	    push( @DIR, $_ );
	} else {
	    print STDERR "不正なコマンドラインオプションが指定されています : $_\n\n";
	    &usage;
	}
    }
}



#================================================================================
#		ゴミを探す
#================================================================================
for my $dir ( @DIR ){
    print "$dir の下のごみを再帰的に探しています。\n" unless $SILENT;
    find( \&judge, $dir );
}
if( @FILES ){
    if( $CRON ){
	print join("\n", @FILES), "\n";
    } else {
	my %file;
	grep( push( @{ $file{ dirname( $_ ) } }, basename( $_ ) ), @FILES );
	for my $dir ( sort keys %file ){
	    my( @file ) = sort @{$file{$dir}};
	    my $top = shift( @file );
	    print "$dir:\n  $top";
	    my $col = length($top) + 2;
	    for( @file ){
		$col += 2;
		$col += length($_);
		if( $col >= 79 ){
		    print ",\n  $_";
		    $col = length($_) + 2;
		} else {
		    print ", $_";
		}
	    }
	    print "\n";
	}
    }
    exit 2 if $DEBUG;
    unless( $FORCE ){
	print "これらのごみファイルをすててもいい? ";
	if( <STDIN>!~/^(y|yes)$/ ){
	    print "ごみを残しとくなんて信じられへん。\n";
	    exit 1;
	}
    }
    print "ごみをそうじしています。\n" unless $SILENT;
    unlink(@FILES);
}
exit 0;



#================================================================================
#		ゴミを判定する関数
#================================================================================
sub judge {
    return if /^\.{1,2}$/;		# . と .. は無視

    return if -d $_;			# ディレクトリはゴミではない

    my $name = $File::Find::name;
    my $dir  = $File::Find::dir;

    for my $ExceptFile ( @ExceptFile ){
	return if $name eq $ExceptFile;
    }

    for my $ExceptDir ( @ExceptDir ){
	return if $dir=~m%^(?:$ExceptDir$|$ExceptDir/)%;
    }

    if( m/~$/ || m/^#/ || m/^%.+%$/ || $_ eq 'core' || $_ eq 'a.out' || $_ eq 'dead.letter' ){
        push( @FILES,$name );
        return;
    }

    if(( /^(\.newsrc.*?)\.emg$/ )&&( -e $1 )){
	push( @FILES,$name );
	return;
    }

    if(( m/^,\d+$/ )&&( $dir=~m%^(?:$MailDir$|$MailDir/)%o )){
	push( @FILES,$name );
	return;
    }

    if(( m/^Incoming/ )&&( $dir=~m%^(?:$GnusDir$|$GnusDir/)%o )){
	if( -M $name > 7 ){
	    push( @FILES, $name );
	    return;
	}
    }

    if(( m/^w3m(?:cache|frame|src|tmp)/ )&&( $dir=~m%^(?:$W3mDir$|$W3mDir/)%o )){
	if( -M $name > 1 ){
	    push( @FILES, $name );
	    return;
	}
    }

    if(( m/^w3m(?:cache|frame|src|tmp)/ )&&( $dir=~m%^(?:$W3mmeeDir$|$W3mmeeDir/)%o )){
	if( -M $name > 1 ){
	    push( @FILES, $name );
	    return;
	}
    }

    # TeX の余分なファイルを取り除く
    if(( m/\.(ps|aux|aux\.bak|bbl|blg|dvi|lof|lot|fff|ttt|log|toc|idx|dep)$/ )&&( -e $`.'.tex' )){
        push( @FILES, $name );
        return;
    }

    if(( m/\.aux$/ )&&( -e $` )){
        push( @FILES, $name );
        return;
    }

    if( /^\.gscache\./ ){
	if( -M $name > 7 ){
	    push( @FILES, $name );
	    return;
	}
    }

    # 実体のない Symbolic Link の検出
    push( @FILES, $name ) if( -l && ! -e );
}



#================================================================================
#		利用法を表示する関数
#================================================================================
sub usage {
    system "pod2text $0";
    exit 1;
}



__END__

=head1 NAME

clean.perl - 余分なファイルを消去するスクリプト

=head1 SYNOPSIS

 clean.perl [option]... [directory]...

=head1 DESCRIPTION

C<clean.perl> は、引数によって指定されたディレクトリ以下のごみファイル
を消去するスクリプトです。

ディレクトリの指定が省略されている場合には、CLEANOPT 環境変数をオプショ
ンとして利用しようとします。それでも、対象となるディレクトリが見つから
ない場合には、ホームディレクトリを対象とします。

=head1 OPTIONS

=over 4

=item -f , --force

ファイルを消去する時の確認を省略します。

=item -n , --debug

ごみと判定されたファイルのリストの表示のみを行います。

=item -e FILE , --exclude-file FILE

指定されたファイルを、ゴミとして捨てないように指定します。(複数指定可)

=item -E DIRECTORY , --exclude-dir DIRECTORY

指定されたディレクトリに存在するファイルを、ゴミとして捨てないように指
定します。(複数指定可)

=item -m DIRECTORY , --mail-dir DIRECTORY

指定されたディレクトリをメールのフォルダと見なし、そのディレクトリに存
在するファイルに対しては、特殊なゴミ判定ルールを適用します。

=item -c , --cron

環境変数を無視します。

=item --help

このメッセージを出力します。

=back

=head1 ENVIRONMENT

=over 4

=item CLEANOPT

ゴミファイルを探索する対象となるディレクトリを指定せずに C<clean.perl> 
を実行した場合、この環境変数の内容をコマンドラインオプションとして利用
しようとします。

例えば、F</home/user/tmp> 以下のファイルについてはどんなファイルも削除
しないようにするためには、

    clean.perl -e /home/user/tmp

というオプションを用います。このオプションを毎回指定することが面倒な人
は、次のように環境変数 CLEANOPT を設定しておきましょう。

    export CLEANOPT="-e /home/user/tmp"

このように設定しておくと、単に、

    clean.perl

というコマンドを実行するだけで同じ結果が得られます。

=back

=head1 BUGS

ごみの定義はソースを参照してください。

=head1 AUTHOR

TSUCHIYA Masatoshi <tsuchiya@namazu.org>

=head1 COPYRIGHT

利用及び再配布については GPL または Artistic License に従ってください。

=cut