職場で役立つ(かもしれない)Tclツール

　「かもしれない」ですからご期待なきよう… なお、職場で使える(かもしれない。しつこくで済みません)アプリケーションということで、 ファイル処理、テキスト処理がメインになります。 そのため、Standard Tcl Library 略してtcllibはほぼ必須となっています。 tcllibについて詳しくは、世界の拡張レビュー分室のtcllibのページ でご紹介しています。

一定以上新しい/古いファイルを探すツール
日本語対応grep
ディレクトリ内のエントリを比較する
zipアーカイブ、tar.gzアーカイブを作る


一定以上新しい/古いファイルを探すツール

 　UNIXのfindコマンドの-mtimeオプションのように、 最終編集時刻が今日からn日前以前／以降のファイルを、 指定したディレクトリ以下を再帰的に検索して表示します。 追加で、特定の日付以前／以降にも対応しています。 簡単にいうと、findコマンドのディレクトリ再帰検索版ということですね。 

#
# newfiles.tcl
# 今日からn日前以降に編集されたファイルの一覧を出力します。
# 2005/03/20
#
package require fileutil

lassign $argv basedir dateExp
if {$dateExp eq ""} {
    puts stderr "usage: $argv0 dirName dateExp"; exit 1
}

#
# 日付を表す文字列dateStrから、clock scanコマンドと同様に、
# clock値に変換して返します。
# YYYYMMDD,YYYY-MM-DD,YYYY/MM/DDを5文字目の文字で判定して、
# どの形式でもclock値に変換することができます。
# (これ以外の書式は駄目です)
#
proc scanDate dateStr {
    set sep [string range $dateStr 4 4]
    if {$sep eq "-"} {
        return [clock scan $dateStr -format "%Y-%m-%d"]
    } elseif {$sep eq "/"} {
        return [clock scan $dateStr -format "%Y/%m/%d"]
    } else {
        return [clock scan $dateStr -format "%Y%m%d"]
    }
}

#
# UNIXコマンドfindの-mtimeオプションのように、
# 今日よりn日前以降、または以前に編集されたファイルの一覧、
# または特定の日付以降、または以前に編集されたファイルの一覧を、
# basedirディレクトリ以下を再帰的に探して出力します。
#
# 引数：
#   basedir: 検索の起点となるディレクトリ
#   dateExp: 日付の表現。次のいずれかが可能です。
#     +n ... nは整数。今日よりn日前以前に編集されたファイルを探します。
#            (当日も含む)
#     -n ... nは整数。今日よりn日前以降に編集されたファイルを探します。
#            (当日も含む)
#     日付+ ... 指定した日付以前に編集されたファイルを探します。
#     日付- ... 指定した日付以降に編集されたファイルを探します。
#   +を未来、-を過去と想像すると混乱するのでご注意下さい
#   (findコマンドの+,-からの連想で)
#   日付は、YYYYMMDD,YYYY-MM-DD,YYYY/MM/DDのいずれかで指定します。
#
proc findMtime {basedir dateExp} {
    set fchar [string range $dateExp 0 0]

    if {$fchar in {"+" "-"}} {
        # 現在の時刻
        set now [clock seconds]
        set temp [clock format $now -format "%Y%m%d"]
        set today [clock scan $temp -format "%Y%m%d"]

        set days [string range $dateExp 1 end]

        # 基準日の零時
        set theday [clock add $today -$days day]
    } else {
        if {[regexp {(.+)([\+\-])} $dateExp all dateStr fchar]} {
            set theday [scanDate $dateStr]
        } else {
            error "日付の末尾に+か-の符号が必要です。"
        }
    }

    ##puts [clock format $theday -format "%Y/%m/%d %H:%M"]

    foreach path [::fileutil::findByPattern $basedir -glob *] {
        if [file isfile $path] {
            set mtime [file mtime $path]
            if {$fchar eq "+"} {
                set b [expr ($mtime <= $theday)]
            } else {
                set b [expr ($mtime >= $theday)]
            }
            if $b {
                set mtimestr [clock format $mtime -format "%Y/%m/%d %H:%M"]
                set sz [file size $path]
                puts [format "%-15s %10d %s" $mtimestr $sz $path]
            }
        }
    }
}

findMtime $basedir $dateExp


日本語対応grep

 　tcllibにはUNIXのgrepコマンドと同様のgrepコマンドがありますが、 UNIXのgrepコマンドにもtcllibのgrepコマンドにもある制約は、 そのファイルで使われている日本語の文字コードを意識しないと、 日本語の文字列は検索できないという点です。 つまり、日本語の文字列で検索をかけるには、 そのファイルが書かれている文字コードを事前に知っておく必要があります。
　それで、手前みそ拡張dpuを作った中に、 jpidentifyという、ファイルをちょっとのぞいて日本語の文字コードを自動で予測するコマンドを作ったので、 これによって、 ファイルがJIS、シフトJIS、日本語EUC、UTF-8のいずれで書かれていても、 中身をgrepできるコマンドを作りました。 

package provide ushidpufile 1.0
#
# ushidpufile.tcl
# ファイル操作に関する共通ルーチン群です。
# dpuパッケージが必要です。
# 2005/11/20
#

package require dpu

namespace eval ushidpufile {

# ファイルfileNameに、正規表現patternが含まれるかどうかを判定します。
# その際、fileNameの日本語文字コードを自動的に判別して、
# そのコードで読み込んで探すことが出来ます。
# 但し、バイナリファイルと判定された場合、検索をせずに
# 「見つからなかった」として返すので、バイナリファイル中の検索には
# 使えません。
#
# 引数：
#   fileName: ファイル名(完全修飾のパス)。見つからないとエラーが発生します。
#   pattern:  検索する正規表現
#
# 戻り値：
#   見つかったら{行番号 行の文字列}のリスト(リストのリスト)で返します。
#   見つからなければ空文字列を返します。
#
proc jgrep {fileName pattern} {
    set enc [dpu::jpidentify $fileName]
    if {$enc in {"binary" "unknown"}} {
        return {}
    }
    set fin [open $fileName r]
    fconfigure $fin -encoding $enc
    set lineno 1
    set rlist {}
    while {! [eof $fin]} {
        set buf [gets $fin]
        if {[regexp $pattern $buf]} {
            lappend rlist [list $lineno $buf]
        }
    }
    close $fin
    return $rlist
}

namespace export *
}

使い方は、上記の内容を"ushidpufile.tcl"という名前で保存すると、 同ディレクトリにpkgIndex.tclを作り、 

package ifneeded ushidpufile 1.0 [list source [file join $dir ushidpufile.tcl]]

このような行を追加しておきます。そして 

package require ushidpufile
namespace import ushidpufile::*
puts [jgrep "c:/usr2/java/webapps/abc01/doc/temp01.xml" "日本語の検索文字列"]

こんな感じでOKと思います。 戻り値は、{行番号 その行の文字列} を該当行分だけ含むリストです。


ディレクトリ内のエントリを比較する

 2つのディレクトリをそれぞれ再帰的に検索し、内容を比較し、差異があれば出力します。 具体的には、片方にしかないファイルや、両方にあってもファイルサイズが異なるファイルを検出して報告します。 (比較するのはサイズまでです。ファイルの内容は比較しません)
これはJ2EE Webアプリケーションのように、階層が深いディレクトリを版管理しているときに使います。 基本的には版管理しているので、以前の版と今の版の差異は把握できているはずなのですが、 改修の間隔が空いてしまうと、本ソースとしている置き場所と、 本当に本番環境で今動いているディレクトリが本当に、ほんとーうに同一のものなのかを、 念のために確認したい、という小心者の方にはお勧めの、いやいや、何ですか？ ただし、このスクリプト自体が正しいかどうかは十分検証していません。(帰れ) つまり、結局かなり無謀なことをしています。(帰れ) 

#! /bin/sh
# the next line restarts using tclsh \
exec tclsh "$0" "$@"
#
# difftool.tcl
# 引数で指定された２つのディレクトリに含まれるファイルを比較します。
# ファイルの比較はサイズでの比較までで、内容の比較は行いません。
#
package require fileutil

# 内容が全く同じファイルは表示しない場合、1をセット
set ShowOnlyDiff 1

if {[llength $argv] != 2} {
    puts stderr "usage: $argv0 dir1 dir2"; exit 1
}
set dir1 [lindex $argv 0]
set dir2 [lindex $argv 1]

# pwdが返す値に「正規化」します。findByPatternは、パスの部分を内部的に
# pwdで取得するので、これをしないと、stripdirプロシージャの処理で、
# パスの部分を削ることができません。
cd $dir1; set dir1 [pwd]
cd $dir2; set dir2 [pwd]

set dir1files [::fileutil::findByPattern $dir1 -glob *]
set dir2files [::fileutil::findByPattern $dir2 -glob *]

set gg {};set g1 {};set g2 {};set gd {}

# pathからdirより後ろの部分を返します。(通常、最初の文字は/になります)
proc stripdir {path dir} {
    set index [string first $dir $path]
    if {$index == -1} { return $path } else {
        return [string range $path [expr $index+[string length $dir]] end]
    }
}
foreach e $dir1files {
    set p "$dir2[stripdir $e $dir1]"
    if {[file exists $p]} {
        if {[file size $e] != [file size $p]} { lappend gd $e } { lappend gg $e }
    } else { lappend g1 $e }
}
foreach e $dir2files {
    set p "$dir1[stripdir $e $dir2]"
    if {! [file exists $p]} { lappend g2 $e }
}

puts "dir1 $dir1 のみにあるファイル:"
foreach e $g1 { puts $e }
puts "dir2 $dir2 のみにあるファイル:"
foreach e $g2 { puts $e }
puts "両方にあるけどサイズが異なるファイル:"
foreach e $gd { puts $e }
if {! $ShowOnlyDiff} {
    puts "files which exists in both :"
    foreach e $gg { puts $e }
}
# end.


zipアーカイブ、tar.gzアーカイブを作る

 Tclスクリプトでzipアーカイブ、tar.gzアーカイブを作れます。 というこのスクリプトどおりの動作なら、Lhacaなど多数のフリーウェアがあるので、 Tclで自分で書く必要は全くないのですが、 「ある種類のファイルはアーカイブから除きたい」 という場合に、これらを手直しして使えると思います。
私が使っているのは、これもJ2EE Webアプリケーション開発用途で、 Webアプリケーションのディレクトリを圧縮してメールで送信する際に、 *.jarはアーカイブに含めないようにしています。 WEB-INF/lib/*.jarは毎回自分で書き換えるものではないうえにファイルサイズが大きいので、 メールで送る際にはよく邪魔になります。 以下はzipを作るスクリプトです。 

package require fileutil
package require dpu

set basedir C:/usr/lang/tcltk/tclsamples

set files [::fileutil::findByPattern $basedir -glob *]
set files2 {}
# filesから、ディレクトリは除いてfiles2に格納
# また、そのときにファイル名に含まれる起点ディレクトリは"."に置き換えて格納
foreach e $files {
    if {[file isfile $e]} {
        regsub $basedir $e "." all; lappend files2 $all
    }
}
cd $basedir
::dpu::zipcreate C:/usr/lang/tmptmp.zip $files2

ほとんど同じですが、tar.gzを作るスクリプトです。 

package require fileutil
package require dpu

set basedir C:/usr/lang/tcltk/tclsamples

set files [::fileutil::findByPattern $basedir -glob *]
set files2 {}
# filesから、ディレクトリは除いてfiles2に格納
# また、そのときにファイル名に含まれる起点ディレクトリは"."に置き換えて格納
foreach e $files {
    if {[file isfile $e]} {
        regsub $basedir $e "." all; lappend files2 $all
    }
}
cd $basedir
::dpu::entar C:/temp/tmptmp.tar.gz $files2


なおこれらの例では、 Windows環境でもファイルのパスにバックスラッシュではなく必ずスラッシュを使わないと、 regsubコマンドがエラーを吐くという欠点があります。

その他
dpuscript-0.1.zip
tclutils-0.1.zip(dpuscriptも同梱)
tkutils-0.2.zip

やねうらの top
(first uploaded 2005/11/20 last updated 2015/02/28, MISUMI URANO)