M.Hiroi's Home Page

Tcl/Tk GUI Programming

Tcl/Tk お気楽 GUI プログラミング実用編

[ Home | Tcl/Tk | Tcl/Tk入門 ]

●filter

リスト : filter の使用例１

oo::class create Foo {
    filter baz1 baz2

    method foo {a} {
        puts "Foo::foo $a"
    }
    method bar {a b} {
        puts "Foo::bar $a $b"
    }

    method baz1 args {
        puts "Foo::baz1 called"
        next {*}$args
        puts "Foo::baz1 ended"
    }
    method baz2 args {
        puts "Foo::baz2 called"
        next {*}$args
        puts "Foo::baz2 ended"
    }
}

Foo create a
a foo 10
a bar 20 30

Foo::baz1 called
Foo::baz2 called
Foo::foo 10
Foo::baz2 ended
Foo::baz1 ended
Foo::baz1 called
Foo::baz2 called
Foo::bar 20 30
Foo::baz2 ended
Foo::baz1 ended

リスト : filter の使用例２

oo::class create Foo {
    method foo {a} {
        puts "Foo::foo $a"
    }
    method bar {a b} {
        puts "Foo::bar $a $b"
    }
}

oo::class create Baz {
    method baz1 args {
        puts "Baz::baz1 called"
        next {*}$args
        puts "Baz::baz1 ended"
    }
    method baz2 args {
        puts "Baz::baz2 called"
        next {*}$args
        puts "Baz::baz2 ended"
    }
}

Foo create a
Foo create b

oo::objdefine a {
    mixin Baz
    filter baz1 baz2
}

a foo 10
a bar 20 30
b foo 1
b bar 2 3

Baz::baz1 called
Baz::baz2 called
Foo::foo 10
Baz::baz2 ended
Baz::baz1 ended
Baz::baz1 called
Baz::baz2 called
Foo::bar 20 30
Baz::baz2 ended
Baz::baz1 ended
Foo::foo 1
Foo::bar 2 3

リスト : filter の使用例３

oo::class create Baz {
    method baz1 args {
        puts "Baz::baz1 called"
        next {*}$args
        puts "Baz::baz1 ended"
    }
    method baz2 args {
        puts "Baz::baz2 called"
        next {*}$args
        puts "Baz::baz2 ended"
    }
}

oo::class create Foo {
    mixin Baz
    filter baz1 baz2

    method foo {a} {
        puts "Foo::foo $a"
    }
    method bar {a b} {
        puts "Foo::bar $a $b"
    }
}

oo::class create Bar {
    superclass Foo
    method foo {a} {
        next $a
        puts "Bar::foo $a"
    }
    method oops {a b c} {
        puts "Bar::oops $a $b $c"
   }
}

Bar create a

a foo 10
a oops 20 30 40

Baz::baz1 called
Baz::baz2 called
Foo::foo 10
Bar::foo 10
Baz::baz2 ended
Baz::baz1 ended
Baz::baz1 called
Baz::baz2 called
Bar::oops 20 30 40
Baz::baz2 ended
Baz::baz1 ended

リスト : filter の使用例４

oo::class create A {
    filter bar_a
    method bar_a {} {
        puts "A::bar_a"
        next
    }
    method foo {} {
        puts "A::foo"
    }
}

oo::class create B {
    superclass A
    filter bar_b
    method bar_b {} {
        puts "B::bar_b"
        next
    }
    method foo {} {
        next
        puts "B::foo"
    }
}

oo::class create C {
    superclass A
    filter bar_c
    method bar_c {} {
        puts "C::bar_c"
        next
    }
    method foo {} {
        next
        puts "C::foo"
    }
}

oo::class create D {
    superclass B C
    filter bar_d
    method bar_d {} {
        puts "D::bar_d"
        next
    }
    method foo {} {
        next
        puts "D::foo"
    }
}

D create d
puts [info object call d foo]
d foo

{filter bar_d ::D method} {filter bar_b ::B method} {filter bar_a ::A method} {filter bar_c ::C method} 
{method foo ::D method} {method foo ::B method} {method foo ::C method} {method foo ::A method}
D::bar_d
B::bar_b
A::bar_a
C::bar_c
A::foo
C::foo
B::foo
D::foo

●forward

% oo::class create Foo {
    forward foo test 1 2 3
}
::Foo
% proc test args {
    puts "test $args"
}
% Foo create a
::a
% a foo
test 1 2 3
% a foo 4 5 6
test 1 2 3 4 5 6

% oo::class create Bar
::Bar
% Bar create b
::b
% oo::objdefine b {
    forward foo test 10 20 30
}
% b foo
test 10 20 30
% b foo 40 50 60
test 10 20 30 40 50 60

リスト : forward の使用例

oo::class create Foo

oo::objdefine Foo {
    variable x
    method get_x {} {
        return $x
    }
    method set_x {a} {
        set x $a
    }
}

oo::define Foo {
    forward get_x Foo get_x
    forward set_x Foo set_x
}

Foo set_x 1
puts [Foo get_x]
Foo create a
puts [a get_x]
a set_x 10
puts [a get_x]

1
1
10

●oo::object

% oo::object create a
::a
% oo::object create b
::b
% oo::objdefine b {
    variable x
    method getx {} {
        return $x
    }
    method setx {a} {
        set x $a
    }
}
% b setx 10
10
% b getx
10
% a setx 100
unknown method "setx": must be destroy or foo

% oo::object create singleton
::singleton
% oo::objdefine singleton {
    method foo {} {
        puts "foo!!"
    }
    method baz {a} {
        puts "baz $a"
    }
}
% singleton foo
foo!!
% singleton baz 10
baz 10
% a foo
unknown method "foo": must be destroy

% oo::class create Foo {
    method unknown {name args} {
        Foo $name {*}$args
    }
}
::Foo
% oo::objdefine Foo {
    method foo {} {
        puts "Foo foo!!"
    }
    method bar {a} {
        puts "Foo bar $a"
    }
}
% Foo create a
::a
% a foo
Foo foo!!
% a bar 123
Foo bar 123
% a baz
unknown method "baz": must be bar, create, destroy, foo or new

●oo::class

リスト : クラス変数 xx を有するクラスを生成 (test0.tcl)

oo::class create Foo {
    superclass oo::class

    variable xx
    method getxx {} {
        return $xx
    }
    method setxx {a} {
        set xx $a
    }
}

Foo create Bar {
    variable a
    forward getxx Bar getxx
    forward setxx Bar setxx

    constructor {} {
        set a 0
    }

    method geta {} {
        return $a
    }
    method seta {x} {
        set a $x
    }
}

% source test0.tcl
::Bar
% info object isa metaclass Foo
1
% info object isa metaclass Bar
0
% Bar create x
::x
% Bar create y
::y
%
% x setxx 100
100
% y getxx
100
% y setxx 1000
1000
% x getxx
1000
% x seta 10
10
% y seta 1
1
% x geta
10
% y geta
1

リスト : シングルトンパターン (test1.tcl)

oo::class create Singleton {
    superclass oo::class
    unexport create

    variable obj
    method new args {
        if {![info exists obj]} {
            set obj [next {*}$args]
        }
        return $obj
    }
}

Singleton create Foo {
    method foo {} {
        puts "Singleton Foo!!"
    }
}

Singleton create Bar {
    variable x
    constructor {a} {
        set x $a
    }
    method bar {} {
        puts "Singleton Bar $x"
    }
}

% source test1.tcl
::Bar
% Foo new
::oo::Obj14
% Foo new
::oo::Obj14
% [Foo new] foo
Singleton Foo!!
% Foo create a
unknown method "create": must be destroy or new

% Bar new 123
::oo::Obj15
% [Bar new 456] bar
Singleton Bar 123
% set b [Bar new 789]
::oo::Obj15
% $b bar
Singleton Bar 123

●簡単なプログラム (連結リスト)

クラスと継承の簡単な例題として、「連結リスト」とそれを継承した「制限付き連結リスト」を作成します。Tcl/Tk にはリストがあるので、連結リストを自作する必要はないのですが、TclOO の勉強ということで、あえてプログラムを作ってみましょう。

連結リストの概要は拙作のページ Python 入門第 5 回: 連結リスト と Python 入門第 6 回: 制限付きリスト をお読みください。

表 : クラス LinkedList のメソッド
名前機能
LinkedList create (or new)LinkedList の生成
xs insert n x連結リスト xs の n 番目に x を挿入する
xs get n連結リスト xs の n 番目の要素を求める
xs set n x連結リスト xs の n 番目の要素を x に書き換える
xs delete n連結リスト xs の n 番目の要素を削除
xs length連結リスト xs の要素数を返す
xs is_empty連結リスト xs が空であれば真 (1)を返す
xs print連結リスト xs を表示する

表 : クラス FixedList のメソッド
名前機能
FixedList create (or new) size大きさ size の FixedList を生成する
xs insert n xリスト xs の n 番目に x を挿入, 挿入できない場合はエラーを送出する
xs is_fullリスト xs が満杯ならば真 (1) を返す
 
#
# linkedlist.tcl : 連結リスト (TclOO のサンプル)
#
#                  Copyright (C) 2019 Makoto Hiroi
#

# コンスセル
oo::class create Cell {
    variable a d
    constructor {x {y 0}} {
        set a $x
        set d $y
        # puts "Cell new [self object]"
    }

    method car {} { return $a }
    method cdr {} { return $d }
    method set_car {x} { set a $x }
    method set_cdr {y} { set d $y }

    destructor {
        # puts "Cell destroy [self object]"
    }
}

# コンスセルか
proc consp {xs} {
    info object isa typeof $xs Cell
}

# 連結リスト
oo::class create LinkedList {
    variable header size
    unexport nth

    constructor {} {
        set header [Cell new 0 0]
        set size 0
    }

    destructor {
        set cp $header
        while {[consp $cp]} {
            set cp1 [$cp cdr]
            $cp destroy
            set cp $cp1
        }
    }

    # 作業用 : n 番目のセルを求める
    method nth {n} {
        set i -1
        set cp $header
        while {$i < $n} {
            if {![consp $cp]} {
                break
            }
            set cp [$cp cdr]
            incr i
        }
        return $cp
    }

    # n 番目の要素を求める
    method get {n} {
        set cp [my nth $n]
        if {![consp $cp]} {
            error "List::get $n, out of range"
        }
        return [$cp car]
    }

    # n 番目の要素を書き換える
    method set {n val} {
        set cp [my nth $n]
        if {![consp $cp]} {
            error "List::set $n $val, out of range"
        }
        set old_val [$cp car]
        $cp set_car $val
        return $old_val
    }

    # n 番目に val を挿入
    method insert {n val} {
        set cp [my nth [expr $n - 1]]
        if {![consp $cp]} {
            error "List::insert $n $val, out of range"
        }
        set cp1 [Cell new $val [$cp cdr]]
        $cp set_cdr $cp1
        incr size
        return $val
    }

    # n 番目の要素を削除
    method delete {n} {
        set cp [my nth [expr $n - 1]]
        if {![consp $cp] || ![consp [$cp cdr]]} {
            error "List::delete $n, out of range"
        }
        set cp1 [$cp cdr]
        set val [$cp1 car]
        $cp set_cdr [$cp1 cdr]
        $cp1 destroy
        set size [expr $size - 1]
        return $val
    }

    # リストは空か
    method is_empty {} {
        expr ![consp [$header cdr]]
    }

    # 要素数
    method length {} {
        return $size
    }

    # 表示
    method print {} {
        set cp [$header cdr]
        while {[consp $cp]} {
            puts -nonewline "[$cp car] "
            set cp [$cp cdr]
        }
        puts ""
    }
}

# 制限付き連結リスト
oo::class create FixedList {
    superclass LinkedList
    variable limit

    constructor {a} {
        next
        set limit $a
    }

    # n 番目に val を挿入
    method insert {n val} {
        if {[my length] >= $limit} {
            error "FixedList::insert $n $val, over the limit"
        }
        next $n $val
    }

    # リストは満杯か
    method is_full {} {
        expr [my length] == $limit
    }
}

# 簡単なテスト
LinkedList create a
puts [a is_empty]
puts [a length]
foreach x {0 1 2 3 4} {
    a insert $x [expr $x + 1]
}
a print
puts [a is_empty]
puts [a length]
foreach x {0 1 2 3 4} {
    puts [a get $x]
}
foreach x {0 1 2 3 4} {
    a set $x [expr [a get $x] * 10]
}
a print
while {![a is_empty]} {
    puts [a delete 0]
}
a print
puts [a is_empty]
puts [a length]

FixedList create d 5
d print
foreach x {1 2 3 4 5 6} {
    if {[d is_full]} {
        break
    }
    d insert 0 $x
}
d print
while {![d is_empty]} {
    puts [d delete 0]
}
d print
foreach x {1 2 3 4 5 6} {
    if {[d is_full]} {
        break
    }
    d insert 0 $x
}
d print

C>tclsh linkedlist.tcl
1
0
1 2 3 4 5
0
5
1
2
3
4
5
10 20 30 40 50
10
20
30
40
50

1
0

5 4 3 2 1
5
4
3
2
1

5 4 3 2 1

●例外処理

% expr 10 / 0
divide by zero
% set errorInfo
divide by zero
    while executing
"expr 10 / 0"
% set errorCode
ARITH DIVZERO {divide by zero}

% proc foo {} { error "oops!" }
% foo
oops!
% set errorInfo
oops!
    while executing
"error "oops!" "
    (procedure "foo" line 1)
    invoked from within
"foo"
% set errorCode
NONE

% proc bar {a} { error "oops!" "bar $a" "bar error"}
% bar 100
oops!
% set errorInfo
bar 100
    (procedure "bar" line 1)
    invoked from within
"bar 100"
% set errorCode
bar error

% catch {expr 1 + 2} var
0
% set var
3
% catch {expr 1 + a} var
1
% set var
invalid bareword "a"
in expression "1 + a";
should be "$a" or "{a}" or "a(...)" or ...
% catch {error oops} var
1
% set var
oops
% catch {break} err
3
% set err
% catch {continue} err
4
% set err
% catch {return} err
2
% set err
%

% proc foo {} {puts "foo!"}
% proc bar {} {puts "bar!"; error "Global Exit!!"}
% proc baz {} {puts "baz!"}
% proc test {} {foo; bar; baz}

% if {[catch {test} err]} {
    puts $err
}
foo!
bar!
Global Exit!!
Copyright (C) 2019 Makoto Hiroi
All rights reserved.
[ Home | Tcl/Tk | Tcl/Tk入門 ]