파일 복사 진행 상황을 tablelist에 표시하기

어찌하다 보니 아래의 예제가 만들어졌습니다. 테스트 코드로 만든 거라 지저분하고 정리는 안되어 있지만 동작은 합니다. 참고하실 분은 참고하세요. 이 예제의 핵심은 파일 복사 진행 상황을 tablelist의 컬럼에 프로그레스바 형태로 표시해 줍니다.

package require img::png
package require tablelist
set src "c:/temp"
set dest "E:/Temp/ddd"

proc makewin {} {
        variable tbl

        set tf .tf
        frame $tf -class ScrollArea
        set tbl $tf.tbl
        set vsb $tf.vsb
        tablelist::tablelist $tbl \
                -columns {0 "Name" left
                          0 "Progress" center
                          0 "Size (Bytes)" right} \
                -setgrid no -yscrollcommand [list $vsb set] -width 0
        if {[$tbl cget -selectborderwidth] == 0} {
                $tbl configure -spacing 1
        }
        $tbl columnconfigure 0 -name fileName
        $tbl columnconfigure 1 -formatcommand emptyStr -sortmode integer
        $tbl columnconfigure 2 -name size -sortmode integer
        scrollbar $vsb -orient vertical -command [list $tbl yview]

        grid $tbl -row 0 -rowspan 2 -column 0 -sticky news
        grid [$tbl cornerpath] -row 0 -column 1 -sticky ew
        grid $vsb                  -row 1 -column 1 -sticky ns
        grid rowconfigure    $tf 1 -weight 1
        grid columnconfigure $tf 0 -weight 1
        pack $tf  -side top -expand yes -fill both

       
        set button [ttk::button .button -text "Stop"]
        pack $button -side top -anchor ne -pady 5 -padx 3

        return
}

proc emptyStr val { return "" }

proc createFrame {tbl row col w} {
    #
   # Create the frame and replace the binding tag "Frame"
   # with "TablelistBody" in the list of its binding tags
   #
    frame $w -width 102 -height 14 -background ivory -borderwidth 0 -relief solid
    bindtags $w [lreplace [bindtags $w] 1 1 TablelistBody]

    #
   # Create the child frame and replace the binding tag "Frame"
   # with "TablelistBody" in the list of its binding tags
   #
    frame $w.f -height 12 -background red -borderwidth 0 -relief raised
    bindtags $w.f [lreplace [bindtags $w] 1 1 TablelistBody]

    #
   # Manage the child frame
   #
    set size [$tbl cellcget $row,size -text]
   #place $w.f -relwidth [expr {double($size) / $::maxFileSize}]
   #place $w.f -relwidth 0.0

        set [namespace current]::xopy(pb) $w.f
}

proc callback_proc {src dest copied_bytes} {
        set size [file size $src]
        set pb [set [namespace current]::xopy(pb)]
        place $pb -relwidth [expr {double($copied_bytes) / $size}]

        update
}

proc addrow {src dest} {
        variable tbl

    set size [file size $src]
    $tbl insert end [list $dest $size $size]

        set row [expr [$tbl size] -1]
    $tbl cellconfigure $row,1 -window createFrame -stretchwindow yes
        $tbl see end
}

proc xcopyfile {src dest callback} {
        addrow $src $dest

        set in  [open $src r]
        set out [open $dest w]
        chan configure $in  -translation binary
        chan configure $out -translation binary

        set chunk [expr {1024 * 1024}] ; # 1024 kb
        set total 0
       
        while {1} {
                if {[eof $in]} {
                        close $in
                        close $out
                        break;
                }
                incr total $chunk
                fcopy $in $out -size $chunk

                if { $callback ne "" } {
                        if { [info proc $callback] ne "" } {
                                eval $callback $src $dest $total
                        }
                }
        }
}

proc xcopyfile2 {src dest callback} {
        # dest can be dir or file
        eval $callback $src $dest

        file copy -force $src $dest
}

proc xcopy {src dest recurse {pattern *} {ignore_pattern ""}} {
     file mkdir $dest
 
     if {[string equal $pattern *] || !$recurse} {
                 foreach file [glob [file join $src $pattern]] {
                         set base [file tail $file]
                         set sub  [file join $dest $base]
         
                         if {[file isdirectory $file]} {
                                 if {$recurse} {
                                         file mkdir  $sub
                                         xcopy $file $sub $recurse $pattern
                 
                                         # If the directory is empty after the recursion remove it again.
                                         if {![llength [glob -nocomplain [file join $sub *]]]} {
                                                 file delete $sub
                                         }
                                 }
                         } else {
                                 xcopyfile $file $sub [namespace current]::callback_proc
                         }
                 }
     } else {
                 foreach file [glob [file join $src *]] {
                         set base [file tail $file]
                         set sub  [file join $dest $base]
         
                         if {[file isdirectory $file]} {
                                 if {$recurse} {
                                         file mkdir $sub
                                         xcopy $file $sub $recurse $pattern
                 
                                         # If the directory is empty after the recursion remove it again.
                                         if {![llength [glob -nocomplain [file join $sub *]]]} {
                                         file delete $sub
                                         }
                                 }
                         } else {
                                 if {![string match $pattern $base]} {continue}
                                 xcopyfile $file $sub [namespace current]::callback_proc
                         }
                 }
     }
 }

makewin

set recurse 1
xcopy $src $dest $recurse "*"