#!perl
#-----------------------------------------------------------------#
# MacPerl 5.6.1r2に付属してくるドロップレット「tarzipme」の改造版です。
# 改造箇所は「■水沢追加」「■水沢変更」で示しています。
# 「■水沢変更」の場合、次のコメント行はオリジナル。次行がコメントでなければ、それはその行をつぶした、ということ。
# 2006/9/28　水沢・penguin-19・和彦
#-----------------------------------------------------------------#
# 55行目で圧縮対象のディレクトリを指定してください。
#-----------------------------------------------------------------#

use Archive::Tar;
use File::Basename;
use File::Copy;
use File::Find;
use File::Path;

use Mac::Conversions;
use Mac::Dialogs;
use Mac::Events;
use Mac::Files;
use Mac::Fonts;
use Mac::Lists;
use Mac::MoreFiles;
use Mac::QuickDraw;
use Mac::Windows;

use strict;
use constant NO_CONVERSION  => 0;
use constant TEXT           => 1;
use constant MACBINARY      => 2;

$^W = 1;

my($verbose, $ans, $switch, $conv, %con, %style,$target,$targetlist,@targetlists,$scriptdir); # ■水沢変更
# my($verbose, $ans, $switch, $conv, %con, %style); 

use Cwd; # ■水沢追加
$scriptdir = getcwd; # ■水沢追加

$verbose = 1;
$conv = new Mac::Conversions;

%style = (
    NO_CONVERSION, italic,
    TEXT         , normal,
    MACBINARY    , bold,
);
$ans = <<EOT;
Select a method for file conversion.  Select automatic conversion
(where -T means CR to LF conversion, and -B means MacBinarize),
pick a method for each file manually, or do no conversion.
EOT
$ans =~ s/\n/ /g;

$targetlist = "aaaa,bbbb,cccc"; # ■水沢追加。圧縮したいフォルダ名。指定するフォルダはこのスクリプトと同位か下位にある必要がある。
# $targetlist = "bbsfol"; 同じディレクトリにあるbbsfolディレクトリを指定する例
# $targetlist = "webpage:bbsfol"; webpageディレクトリの下にあるbbsfolディレクトリを指定する例
# 複数のフォルダを指定するには、「,」で区切ってください。
# $targetlist = "bbsfol,webpage:bbsfol"; bbsfolと、webpageディレクトリの下にあるbbsfolディレクトリの二つを指定する例

# ■水沢追加ここから
$targetlist =~ s/\+/ /g; # 半角スペースを削除
@targetlists = split( /,/, $targetlist); # ,で分解
foreach $target ( @targetlists ) { # リストごとに処理
	$target = $scriptdir.$target ; # ■水沢追加
	&delfile("$target".".tar.gz"); # ファイルをチェック
	do_it($target); # ■水沢変更
}
# ■水沢追加ここまで
print "Done.\n";

#-----------------------------------------------------------------#
sub do_it {
    my($dir, $tar, $file, @f, $mdir, $ndir, $tdir, $edir);
    local $|;

#     $dir = $ARGV[0]; # ■水沢変更
    $dir = $_[0];# ■水沢追加
    unless ($dir && -d $dir) {
        die "Need directory name";
    }
    $dir  =~ s/:$//;
    $file = get_filename($dir);
    $ndir = basename($dir);
    $edir = "$scriptdir:macperltar:"; # ■水沢変更
#     $edir = "$ENV{TMPDIR}macperltar:";
    $tdir = "$edir$ndir";
    $mdir = dirname($tdir);
    $tar  = new Archive::Tar;

    die "Cannot continue: archive $file exists\n" if -e $file;
    create_dir($dir, $edir, $tdir);
    create_file($file);

    chdir($edir) or die "Can't chdir $edir: $!";

#     $switch = MacPerl::Answer($ans, 'Automatic', 'Manual', 'None'); # ■水沢変更
# Automaticは2
# Manualは1
# Noneは0
$switch = '2'; # ■水沢追加/2が無難なようです
    do_dialog($tdir, $mdir) if $switch == 1;

    print "Converting files ...\n";
    find(sub {
        my $f = $File::Find::name;
        return if ! -f $f || $f =~ /:Icon\n$/;
        (my $n = $f) =~ s/^$mdir//;
        $n = ":$n" unless $n =~ /^:/;
        $n = convert($f, $n) if $switch;
        push @f, $n;
    }, $tdir);

    print "Adding files to archive ...\n";
    $tar->add_files(@f);
    print "Writing archive to <$file> ...\n";
    $tar->write($file, 1);
    print "Cleaning up ...\n";
    rmtree($tdir);
}
#-----------------------------------------------------------------#
sub guess {
    my $f = shift;
    my $guess = 0;
    if (-s $f && -T _) {
        $guess = TEXT;
    } elsif (-s _ && -B _) {
        $guess = MACBINARY;
    } elsif (-B _) {
        my $cat  = FSpGetCatInfo($f);
        $guess = MACBINARY if ($cat->ioFlRLgLen());
    }
    return $guess;
}
#-----------------------------------------------------------------#
sub convert {
    my($f, $n) = @_;
    if ($switch == 2) {
        my $guess = guess($f);
        if ($guess == TEXT) {
            return cr2lf($f, $n);
        } elsif ($guess == MACBINARY) {
            return bi2bin($f, $n);
        } else {
            return leave_alone($f, $n);
        }
    } elsif ($switch == 1) {
        if ($con{$n} == TEXT) {
            return cr2lf($f, $n);
        } elsif ($con{$n} == MACBINARY) {
            return bi2bin($f, $n);
        } else {
            return leave_alone($f, $n);
        }
    }
}
#-----------------------------------------------------------------#
sub leave_alone {
    my($f, $n, $t) = @_;
    print "  Left alone   $n\n" if $verbose;
    return $n;
}
#-----------------------------------------------------------------#
sub bi2bin {
    my($f, $n, $t) = @_;
    undef $t;
    $conv->macbinary($f);
    $n .= '.bin';
    print "  Macbinarized $n\n" if $verbose;
    return $n;
}
#-----------------------------------------------------------------#
sub cr2lf {
    local(*F, $/);
    my($f, $n, $t) = @_;
    open(F, "< $f\0") or die "Can't open $f: $!";
    $t = <F>;
    close(F);
    $t =~ s/\015\012?/\012/g if $t;
    open(F, "> $f\0") or die "Can't open $f: $!";
    print F $t;
    close(F);
    print "  CRLF? to LF  $n\n" if $verbose;
    return $n;
}
#-----------------------------------------------------------------#
sub create_file {FSpCreate(shift, qw/Gzip Gzip/) or die $^E}
#-----------------------------------------------------------------#
sub create_dir {
    my($dir, $edir, $tdir) = @_;
    unless (-d $edir) {mkdir $edir, 0777 or die "Cannot create $edir: $!"}
    rmtree($tdir) if -d $tdir;
    FSpDirectoryCopy($dir, $edir, 1)
        or die "Can't copy $dir to $edir: $^E";
}
#-----------------------------------------------------------------#
sub get_filename {
    my $name = shift;
    my($file, $path) = fileparse($name, '');
    my $tfile = length($file) < 24 ? "$file.tar.gz" :
        length($file) < 28 ? "$file.tgz" :
        substr($file, 0, 23) . "\xC9.tar.gz";
    return "$path$tfile";
}

#=================================================================#
# List stuff for manual selection #
#=================================================================#
sub do_dialog {
    my($tdir, $mdir) = @_;
    my @files;

    find(sub {
        my $f = $File::Find::name;
        return if ! -f $f || $f =~ /:Icon\n$/;
        (my $n = $f) =~ s/^$mdir/:/;
        push @files, $n;
        $con{$n} = [guess($f), 0];
    }, $tdir);

    my $win = MacWindow->new(
        Rect->new(100, 50, 600, 350), 'Files to tarzip',
        1, floatProc(), 1
    );
    $win->sethook(redraw => sub {});
    SetPort($win->window);
    TextFont(geneva());
    TextSize(9);
    my $list = $win->new_list(
        Rect->new(0, 0, 484, 300),
        Rect->new(0, 0, 1, scalar @files),
        Point->new(0, 13), \&myLDEF, 1, 1
    );

    $list->sethook(key=>sub{
        my($mod) = $Mac::Events::CurrentEvent->modifiers();
        if ($_[2] == ord('w') && (($mod & cmdKey()) == cmdKey())) {
            $win->dispose();
            return 1;
        }
        return;
    });
    
    for (my $c = 0; $c <= $#files; $c++) {
        $list->set(0, $c, $files[$c]);
    }
    
    while ($win->window()) {
        WaitNextEvent();
    }
    
    $win->dispose() if defined($win);
    
    END {
        $win->dispose() if defined($win);
    }

    foreach my $n (keys %con) {
        $con{$n} = $con{$n}->[0] % 3;
    }
}
#-----------------------------------------------------------------#
sub myLDEF {
    my($msg, $select, $rect, $cell, $data, $list) = @_;

    return unless $msg == lDrawMsg || $msg == lHiliteMsg;
    my($where) = AddPt($rect->topLeft, $list->indent);
    EraseRect $rect;

    $con{$data}->[0]++ if ($select && ($con{$data}->[1]++ % 2));
    TextFace($style{ $con{$data}->[0] % 3 });
    LSetSelect(0, $cell, $list);

    MoveTo($where->h, $where->v);
    DrawString $data;
}
#-----------------------------------------------------------------#
sub check_value {
    my($win, $list, $x, $y) = @_;
    return if !$list->{'list'};
    $y = LGetSelect(1, Point->new(0,1), $list->{'list'});
    $x = $list->get($y) if $y;
    return if ref($x);
}
#-----------------------------------------------------------------#

# このサブルーチンは■水沢追加
# 同名のtar.gzファイルがあったら、削除する
# &delfile(ファイルパス);　で呼び出し
sub delfile {
	my $checkfile = $_[0];
	if (-e $checkfile){ # ファイルがあったら
		unlink $checkfile ; # 削除する
	}
}

__END__