コマンドラインの操作にもだいぶ慣れたわたしだが、やはりGUIツールがあると便利だろう。
GUIと言えば最近はJavaのSwingがもう最強な気がするが、せっかくPerlで書いたスクリプトをJavaから呼び込んだりというのは、できるんだろうけどせっかくPerlでここまでやったんだからやっぱりあとはPerl/Tkだろう。だが問題がひとつある。それはわたしは今までPerl/Tkてえものを触ったことがないのだ。うちには本すらない。
ところがそんな問題はかなり見事に解決した。広井
誠 氏のウェブサイト で「Perl/Tk memo」という記事が公開されている。これは氏が以前、専門誌に執筆された記事の転載とある。ここにわかりやすい解説とともにサンプルプログラムが満載されていて、予備知識ゼロ状態から半日ほどで、ひととおりのものを作り上げることができた。記事を公開してくださった広井氏には、我がヘボサイト上などで恐縮ながら、感謝の意を表したい。
その「Perl/Tk memo」で初めて、まずモジュールからインストールしなければならないということがわかった。
天気予報に反してさわやかに晴れた日曜日の朝、それならと例によってCPANからのダウンロードとインストールを試みた。install Tk とやったのだが、なぜか知らないがあらゆる関連サイトから接続を拒否されたようだった。日曜は休みなのか、なわけないのだが、しょうがないから自分でダウンロードしてインストールするしかない。
最初少し混乱したのは、CPANには「Perl/Tk」の基本モジュールの他に、さらにこれを用いて開発者諸氏が開発された新たなモジュールがたくさん上がっていることだ。だが基本モジュールはこのようにして手に入れた。
CPANのページからCPAN searchへリンクして、キーワードに「Tk」と入れ、「in」のあとのコンボボックスから「modules」を選択して検索すると、モジュールのリストが表示されるので、その一番トップの「Tk」というヤツにアクセスする。
これは「Tk」というタイトルからリンクすると、説明のページになる。それはありがたいのだがモジュールが欲しい場合は下の欄の「Tk804.025_beta2
」と書いてあるリンクをつつく。
するとダウンロードサイトに行けるが、ここでは最新バージョン以外のものもコンボボックスから選択してもらってこれる。なんて書いたのはつまり、Tkの現在の最新モジュールをもらってきてインストールしようとしたら「これはPerl5.7にしか対応しません」とのことでガーンだった。Solaris9の付属のPerlは5.6.1。ちょっと古いがTk800.023というのを選んでもう一度拝領した。パッチとか出てなくて、2001年5月作、比較的枯れてるかなと期待したのだ。果たしてこれはバッチシだった。
perl Makefile.PL, make, suに上がってmake installでインストールした。そのあと「Perl/Tk memo」の一番簡単なサンプルコードをそっくりコピペさせていただき動かしてみた。ボタンとラベルからなるWindowが表示され、まずはちゃんと動きそうだ。
最も簡単かつ比較的実用的なコンセプトとして、以下のように考えた。
ローカル用とリモート用にそれぞれリストボックスとテキストフィールドを用意する。
GET, PUT, INITボタンを用意する。
プログラム起動時には、ローカルはnonikoホームディレクトリ、リモートはunixshareディレクトリのファイルリストがそれぞれのリストボックスに表示されるようにする。
リストからディレクトリ名を選んでダブルクリックすると、その下の階層へ降りる。
テキストフィールドには基本的に今表示されているファイルリストの親ディレクトリが表示される。ローカルの場合は、そこに絶対パスを入力してEnterすれば、そこからのファイルリストが表示できる。
双方位置決めして、リストからシングルクリックでファイル及びディレクトリ名を選び、PUTあるいはGETボタンを押すと送受信が行われる。
どこにいるかわからなくなったような場合、「INIT」ボタンを押せば、ローカルもリモートも最初の状態に戻る。
そこでまずコンポーネントの配置から。サンプルプログラムに頼りっきりだし、細かい配置の設定がよくわからないので、ずらりと縦長になってしまった。
use Tk;
$top = MainWindow->new();
# Entry Local
$el = $top->Entry( -textvariable => \$lbuffer );
$el->bind("<Return>", \&abspath); #リターンキーでサブルーチンabspath発動
$el->pack();
# ScrolledList Local
$ll = $top->Scrolled('Listbox', -scrollbars => 'se' );
foreach(@lconts){ #@lcontsについては後述
$ll->insert( 'end', $_ );
}
$ll->see( 'end' );
$ll->bind("<Double-1>", \&changelocal );
#ダブルクリックで発動。サブルーチンchangelocalも後述
$ll->pack();
#Entry Remote
$er = $top->Entry( -textvariable => \$rbuffer );
$er->pack();
# ScrolledList Remote
$lr = $top->Scrolled('Listbox', -scrollbars => 'se' );
foreach(@rconts){ #@rcontsについては後述
$lr->insert( 'end', $_ );
}
$lr->see( 'end' );
$lr->bind("<Double-1>", \&changeremote ); #サブルーチンchangeremoteも後述
$lr->pack();
$bget=$top->Button(-text=>"GET", -command=>\&myget)->pack(-side=>left);
$bput=$top->Button(-text=>"PUT", -command=>\&myput)->pack(-side=>left);
$binit=$top->Button(-text=>"INIT", -command=>\&myinit)->pack(-side=>left);
MainLoop();
上述において、起動したときにローカル（ホームディレクトリ）、リモート（共有のディレクトリのルート）のファイルリストがそれぞれ表示されるようにする。そのために初期設定を
url="http://serveraddress/unixshare";
$dir="/export/home/noniko";
$workdir="";
@lconts=getlconts();
@rconts=getrconts();
このgetlconts, getrcontsがそれぞれ、caveman.plで頑張って書いたヘッポコファイルリストサルブーチンである。ターミナルに書き出す代わりに配列にして戻り値として返してやる。
ローカルのファイルリストの任意の行をダブルクリックすることにより発動するサブルーチンchangelocalである。上述のgetlconts()を呼び出している。
リストで選択された行の値を読み取る。
$lfd=$ll->get( 'active' );
これがcaveman.plの$fdにあたる、ディレクトリやファイルの相対パスっていうか名前そのものである。
ファイルリストを更新しなければならない。
$ll->delete(0, 'end'); で、元のファイルリスト表示を全消去する。そのあとファイルリストを取得して再表示する。
これとは別にテキストボックスから絶対パスを入力してファイルリストを取得するのがabspathである。
$dir=$lbuffer;
で、あとはchangelocalと同じようにする。入力系統が全く違うので、ちょっと重複するが別々のサブルーチンにっしてしまった。
リモートのファイルリストの任意の行をダブルクリックすることにより発動するサブルーチンchangeremoteは、やはり基本的にcaveman.plで書いたものと同じである。
putの場合はローカルのファイルリスト、getの場合はリモートのファイルリストからコンポーネントを選択しておいて、ボタンを押す。各リストの選択された行の値がcaveman.plの$fdにあたる。
リソースがすでにある場合はサブウィンドウが現れて確認を促す。yesボタンを押せば上書きをして、サブウィンドウが閉じる。noボタンを押せば何もせずサブウィンドウが閉じる。このコードはgetとputのサブルーチン中にそれぞれ組み込む。たとえば
if($oldremote){ #putしようというリソースがすでにリモートにある場合
$ovrw=$top->Toplevel(); #サブウィンドウの定義
$ovrw->title('Overwriting');
$ovrw->Message(-text=>'Overwrite '.$lfd0."?")->pack(); #上書きしますか？というメッセージ
$ovrw->Button(-text=>'yes', -command=>\&delremote)->pack(-side=>left);
$ovrw->Button(-text=>'no' , -command=>\&closeovrw)->pack(-side=>left);
}
サブルーチンdelremoteは、リモートの古いリソースを削除・上書きしてから、ウィンドウを閉じる。
closeovrwはただウィンドウを閉じる。
実行するとこんなのが出てくる。
これもサイズの調整してないんで。すんません。
といっても、やっぱりまるうつしのコールバックサブルーチンcbだけは抜かしました。
#!/usr/bin/perl
use Tk;
use HTTP::DAV;
my $d;
$lbuffer = "";
$rbuffer="";
$url="http://serveraddress/unixshare";
$dir="/export/home/noniko";
$workdir="";
@lconts=getlconts();
@rconts=getrconts();
$top = MainWindow->new();
# Entry Local
$el = $top->Entry( -textvariable => \$lbuffer );
$el->bind("<Return>", \&abspath );
$el->pack();
# ScrolledList Local
$ll = $top->Scrolled('Listbox', -scrollbars => 'se' );
foreach(@lconts){
$ll->insert( 'end', $_ );
}
$ll->see( 'end' );
$ll->bind("<Double-1>", \&changelocal );
$ll->pack();
#Entry Remote
$er = $top->Entry( -textvariable => \$rbuffer );
$er->pack();
# ScrolledList Remote
$lr = $top->Scrolled('Listbox', -scrollbars => 'se' );
foreach(@rconts){
$lr->insert( 'end', $_ );
}
$lr->see( 'end' );
$lr->bind("<Double-1>", \&changeremote );
$lr->pack();
$bget=$top->Button(-text=>"GET", -command=>\&myget)->pack(-side=>left);
$bput=$top->Button(-text=>"PUT", -command=>\&myput)->pack(-side=>left);
$binit=$top->Button(-text=>"INIT", -command=>\&myinit)->pack(-side=>left);
MainLoop();
#subroutines##
sub abspath{
$dir=$lbuffer;
$ll->delete(0, 'end');
@lconts=getlconts();
foreach(@lconts){
$ll->insert( 'end', $_ );
}
$ll->see( 'end' );
}
sub changelocal{
$lfd=$ll->get( 'active' );
$ll->delete(0, 'end');
if($lfd eq ".."){
my $predir;
my @comps=split(/\//,$dir);
$length=@comps;
for($i=0; $i<$length-2; $i++){
$predir .= $comps[$i]."/";
}
$dir=$predir.$comps[$length-2];
if($dir eq ""){
$dir="/";
$lbuffer="/";
}
else{
$lbuffer=$comps[$length-2];
}
}
else{
$dir=$dir."/".$lfd;
$lbuffer=$dir;
}
@lconts=getlconts();
foreach(@lconts){
$ll->insert( 'end', $_ );
}
$ll->see( 'end' );
}
sub changeremote{
$rfd=$lr->get( 'active' );
$lr->delete(0, 'end');
if($rfd eq ".."){
my $predir2;
my @comps2=split(/\//,$workdir);
$length2=@comps2;
for($i2=0; $i2<$length2-1; $i2++){
$predir2.= "/".$comps2[$i2];
}
$workdir=$predir2;
$rbuffer=$comps2[$length2-2];
}
else{
$workdir.="/".$rfd;
$rbuffer=$rfd;
}
@rconts=getrconts();
foreach(@rconts){
$lr->insert( 'end', $_ );
}
$lr->see( 'end' );
}
sub getlconts{
my @mlc=();
my @cdfil=();
my @cddir=();
opendir (DIR,$dir);
while ($fname=readdir(DIR)){
if ($fname ne "." && $fname ne ".."){
$rname=$dir."/".$fname;
if(-d $rname){
@cddir=(@cddir,$fname);
}
else {
@cdfil=(@cdfil,$fname);
}
}
}
closedir(DIR);
@mlc=("..", @cddir,@cdfil);
return @mlc;
}
sub getrconts{
my @mrc=();
my @opendir=();
my @openfil=();
$d= new HTTP::DAV;
$d->open(-url=>$url.$workdir);
my $resource=$d->propfind(@_);
if ($resource) {
if ($resource->is_collection) {
$rp=$resource->get_property('short_ls');
@rps=split(/\n/,$rp);
$i=0;
foreach(@rps){
if(/^\s+/){
$_=$';
}
/\s+/;
$_=$`;
if($i>1){
if(/\//){
@opendir=(@opendir, $_);
}
else{
@openfil=(@openfil, $_);
}
}
$i++;
}
}
@mrc=("..", @opendir, @openfil);
return @mrc;
}
return @mrc;
}
sub myget{
$rfd0=$lr->get('active');
$localrootdir=$dir;
$remotetarget=$url.$workdir."/".$rfd0;
print ("Local directory:".$localrootdir."\n");
print ("Remote target:".$remotetarget."\n");
$d= new HTTP::DAV;
$d->open(-url=>$url.$workdir);
$oldlocal=$localrootdir."/".$rfd0;
if(-e $oldlocal){
$ovlw=$top->Toplevel();
$ovlw->title('Overwriting');
$ovlw->Message(-text=>'Overwrite '.$rfd0."?")->pack();
$ovlw->Button(-text=>'yes', -command=>\&dellocal)->pack(-side=>left);
$ovlw->Button(-text=>'no' , -command=>\&closeovlw)->pack(-side=>left);
}
else{
$d->get(-url=>$remotetarget, -to=>$localrootdir, -callback=>\&cb);
}
}
sub dellocal{
print( "deleting ".$oldlocal."\n");
if(-d $oldlocal){
$done=`rm -r $oldlocal`;
}
elsif(-f $oldlocal){
unlink($oldlocal);
}
$d->get(-url=>$remotetarget, -to=>$localrootdir, -callback=>\&cb);
$ovlw->withdraw;
}
sub closeovlw{
$ovlw->withdraw;
}
sub myput{
$lfd0=$ll->get('active');
$localrootdir=$dir."/".$lfd0;
$remotetarget=$url.$workdir;
print ("Local directory:".$localrootdir."\n");
print ("Remote target:".$remotetarget."\n");
$d= new HTTP::DAV;
$d->open(-url=>$remotetarget);
my $oldremote=$d->propfind($lfd0);
if($oldremote){
$ovrw=$top->Toplevel();
$ovrw->title('Overwriting');
$ovrw->Message(-text=>'Overwrite '.$lfd0."?")->pack();
$ovrw->Button(-text=>'yes', -command=>\&delremote)->pack(-side=>left);
$ovrw->Button(-text=>'no' , -command=>\&closeovrw)->pack(-side=>left);
}
else{
$d->put(-local=>$localrootdir, -url=>$remotetarget,
-callback=>\&cb);
}
}
sub delremote{
$deletetarget=$remotetarget."/".$lfd0;
print "deleting ".$deletetarget;
$d->delete(-url=>$deletetarget, -callback=>\&cb);
$d->put(-local=>$localrootdir, -url=>$remotetarget,-callback=>\&cb);
$ovrw->withdraw;
}
sub closeovrw{
$ovrw->withdraw;
}
sub myinit{
$url="http://serveraddress/unixshare";
$dir="/export/home/noniko";
$workdir="";
$ll->delete(0, 'end');
$lr->delete(0, 'end');
@lconts=getlconts();
@rconts=getrconts();
foreach(@lconts){
$ll->insert( 'end', $_ );
}
foreach(@rconts){
$lr->insert( 'end', $_ );
}
}