I know this isn't the most efficient code, but it is the first tclapp i have managed to finish, and it seems to work great. Any suggestions would be appreciated.
#mime.tcl
#usage:
# mime.tcl ?-tk? ?-outdir dirname? ?-indir dirname? ?-delay int? ?filename? ?filename...?
#set to a different value if you want it to default to saving to a different directory
#make sure the direcory exists before executing the script
set outdir [file normalize [file join [file dirname [info script]] extracted]]
#other global vars
set debug 0 ;#output extra info
set tkLoaded 0 ;#don't automatically load tk, so this var will be set to 1 if tk is loaded
set indir {} ;#list to stor input directories
set files {} ;#list to store file names
set delay 200 ;#proc that may take a long time to execute will use this to prevent locking up completely, set to 0 for no delay
set version "0.1"
set title "Mime File Attachment Extractor $version"
proc main {argc argv} {
global tkLoaded outdir indir files delay debug title
#load tk if it is on the command line
if {[lsearch -exact $argv -tk] > -1} {
if {[catch {package require Tk}] || $tkLoaded} {
textOut "Tk could not be loaded, continuing without Tk"
set tkLoaded 0
}
}
#see if tk is loaded
set tkLoaded [pkgLoaded Tk]
#create main window, if tk is loaded
createWin
#about stuff
textOut $title
textOut "Extracts attachments from .eml files\n"
#load mime package if available
if {[catch {package require mime}]} {
textOut "\"mime\" package could not be loaded.\nPlease get \"tcllib\" from http://tcl.tk/"
if {!$tkLoaded} {exit 1} else {return}
}
#load base64 package if available
if {[catch {package require base64}]} {
textOut "\"base64\" package could not be loaded.\nPlease get \"tcllib\" from http://tcl.tk/"
if {!$tkLoaded} {exit 1} else {return}
}
if {$debug} {
textOut "args: $argv"
textOut "script: [file normalize [info script]]"
}
#parse command line
for {set i 0} {$i<[llength $argv]} {incr i} {
switch -- [string tolower [lindex $argv $i]] {
-tk {
;#already handled so textOut will work in this proc
}
-outdir {
#output directory, can only have 1, last -outdir on command line has priority
#this proc does not create the directory
incr i
if {[file isdirectory [file normalize [lindex $argv $i]]]} {
set outdir [file normalize [lindex $argv $i]]
} else {
textOut "[file normalize [lindex $argv $i]] does not exist! Using default outdir!"
}
}
-indir {
#list of input directories, can list more than 1 on the command line
incr i
lappend indir [file normalize [lindex $argv $i]]
}
-delay {
#delay for procs that may lock up tk, ignored if not using tk
incr i
if {[string is int [lindex $argv $i]]} {set delay [lindex $argv $i]}
}
default {
lappend files [file normalize [lindex $argv $i]]
}
}
}
#extra info
if {$debug} {
textOut "outdir: $outdir"
textOut "indir: $indir"
textOut "files: $files"
textOut "delay: $delay"
}
#search input directories
searchInput
#exit with error code 0, if tk is not loaded
if {!$tkLoaded} {exit 0}
}
proc searchInput {{index 0}} {
global indir files delay tkLoaded
if {$index < [llength $indir]} {
set dir [lindex $indir $index]
if {[string length $dir] && [file isdirectory $dir]} {
textOut "Searching \"$dir\""
foreach f [glob -nocomplain -directory $dir -types {d f} *] {
if {[file isdirectory $f] && [lsearch -exact $indir $f] < 0} {
lappend indir $f
} elseif {[file isfile $f] && [lsearch -exact $files $f] < 0} {
lappend files $f
}
}
}
incr index
if {$tkLoaded && $delay} {
after $delay "searchInput $index"
} else {
searchInput $index
}
} else {
#we are done searching for files, start processing files
mimeExtract
}
}
proc mimeExtract {{index 0}} {
global files delay tkLoaded outdir debug
if {$index < [llength $files]} {
set cFile [lindex $files $index]
textOut "\nFile: $cFile"
#open the file with mime
if {![catch {set token [mime::initialize -file $cFile]}]} {
if {$debug} {
foreach {p v} [mime::getproperty $token] {textOut "\t$p : $v"}
}
foreach p [mimeGetParts $token] {
mimeSaveFile $p
}
#close the file
mime::finalize $token
} else {
textOut "\tFile is not a Mime file."
}
incr index
if {$tkLoaded && $delay} {
after $delay "mimeExtract $index"
} else {
mimeExtract $index
}
}
}
proc mimeGetParts {token} {
set parts {}
if {![catch {mime::getproperty $token parts}]} {
foreach p [mime::getproperty $token parts] {
lappend parts $p
foreach p1 [mimeGetParts $p] {
lappend parts $p1
}
}
}
return $parts
}
proc mimeGetPartName {token} {
set params [mime::getproperty $token params]
set i [lsearch -exact $params name]
if {$i >= 0} {
incr i
return [lindex $params $i]
}
return
}
proc mimeSaveFile {token} {
global outdir
set name [mimeGetPartName $token]
#if it dos not have a name, return
if {![string length $name]} {return}
#filename
set file [file normalize [file join $outdir $name]]
#make unique filename
#break up file name
set fn [join [lrange [split $name .] 0 end-1] .]
if {[split $name .] > 1} {
set ext [lindex [split $name .] end]
} else {set ext txt}
for {set i 0} {[file exists $file]} {incr i} {
set file [file join $outdir $fn.$i.$ext]
}
textOut "\t$token > $name > $file"
#save attachment
set f [open $file w+]
mime::copymessage $token $f
close $f
#decode attachment
decode $file
}
proc decode {file} {
if {![catch {set f [open $file r]}]} {
set l {}
set decode 0
set encoding text
set data {}
while {![eof $f]} {
gets $f l
set l [string trim $l]
if {!$decode} {
if {![string length $l]} {
if {$encoding == "text"} { break }
set decode 1
} elseif {[lindex $l 0] == "Content-Transfer-Encoding:"} {
set encoding [lindex $l 1]
}
} else {
set data [set data]$l
}
}
seek $f 0 start
close $f
if {$decode && $encoding == "base64"} {
set f [open $file w+]
fconfigure $f -translation binary
set data [base64::decode $data]
puts -nonewline $f $data
close $f
}
}
}
proc textOut {text} {
global tkLoaded
if {$tkLoaded} {
.t configure -state normal
.t insert end "$text\n"
.t see end
.t configure -state disabled
} else {puts $text}
}
proc createWin {} {
global tkLoaded title
if {$tkLoaded} {
#use autoscroll if it is available
if {![catch {package require autoscroll}]} {::autoscroll::wrap}
#create and display text with scrollbars
text .t -state disabled -xscrollcommand ".x set" \
-yscrollcommand ".y set" -font "Courier 10" -wrap none
scrollbar .x -orient h -command ".t xview"
scrollbar .y -orient v -command ".t yview"
grid .t -row 0 -column 0 -sticky news
grid .x -row 1 -column 0 -sticky news
grid .y -row 0 -column 1 -sticky news
grid rowconfigure . 0 -weight 1
grid columnconfigure . 0 -weight 1
wm title . $title
}
}
proc pkgLoaded {pkg} {return [expr ![catch {package present $pkg}]]}
main $argc $argv