GJS 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.
#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 1 ;#proc that may take a long time to execute will use this to prevent locking up completely, set to 0 for no delay
set maxDisp 500 ;#maximum number of lines to display in tk window, set to 0 to disable
set totalFiles 0
set totalAttachments 0
set version "0.5"
set title "Mime File Attachment Extractor $version"
#File type extensions, just in case a file was attached without the extension.
set typeExts {
{image/jpeg jpg}
{image/png png}
{text/html htm}
{multipart/alternative eml}
{text/plain txt}
}
proc main {argc argv} {
global tkLoaded outdir indir files delay debug title maxDisp
#load tk if it is on the command line
if {[lsearch -exact [string tolower $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 https://www.tcl-lang.org/"
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 https://www.tcl-lang.org/"
if {!$tkLoaded} {exit 1} else {return}
}
if {$debug} {
textOut "args: $argv"
textOut "script: [file normalize [info script]]"
}
#parse command line
set help 0
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]}
}
-maxdisp {
incr i
if {[string is int [lindex $argv $i]]} {set maxDisp [lindex $argv $i]}
}
-mh {
if {!$help} {
set help 1
help
return
}
}
default {
lappend files [file normalize [lindex $argv $i]]
}
}
}
#show help if there are no aruments
if {![llength $argv]} {help;return}
#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 help {} {
set ::maxDisp 0
textOut "Usage: mime.tcl ?options? ?files?\n"
textOut "Available options:"
textOut "Switch\tParm\tInfo"
textOut "-mh\t\tDisplay this message\n\t\tHalts all other processing"
textOut "-tk\t\tAttempt to load TK"
textOut "-outdir\tdir\tUse dir instead of default dir\n\t\tto save files to\n\t\tUse only once in command line"
textOut "-indir\tdir\tSearch directory and all sub directories\n\t\tfor files\n\t\tCan be used more than once in command line"
textOut "-delay\tint\tDelay between directory searches,\n\t\tand extraction procedures\n\t\tThis only works with Tk\n\t\tUse only once in command line"
textOut "-maxdisp\tint\tMaximum number of lines to display\n\t\tThis only works with tk\n\t\tUse only once in command line"
textOut "\nYou can list any number of files, be sure to enclose them in double quotes (\")"
}
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 totalFiles totalAttachments
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]}]} {
incr totalFiles
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
}
} elseif {$totalFiles} {
textOut "Task finished:"
textOut "\t$totalFiles mime files processed"
textOut "\t$totalAttachments attachments saved"
}
}
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 debug typeExts totalAttachments
#get the attachment name
set name [mimeGetPartName $token]
#if attachment does not have a name return.
if {![string length $name]} {return}
set name [string map {\\ _ / _ : _ * _ ? _ \" _ < _ > _ | _} $name]
#make unique filename
#break up file name
if {[llength [split $name .]] > 1} {
set fn [join [lrange [split $name .] 0 end-1] .]
set ext [lindex [split $name .] end]
} else {
set fn $name
set ext txt
}
if {[lsearch -glob $typeExts "[mime::getproperty $token content] *"] > -1} {
set ext [lindex [lsearch -glob -inline $typeExts "[mime::getproperty $token content] *"] 1]
}
#filename
set file [file normalize [file join $outdir $fn.$ext]]
#create a new filename
for {set i 0} {[file exists $file]} {incr i} {set file [file join $outdir $fn.$i.$ext]}
#output working attachment name
textOut "\t[mimeGetPartName $token] > $file"
#output debug info
if {$debug} {
textOut "\t\tMime info:"
foreach {p} [mime::getproperty $token -names] {
textOut "\t\t\t$p [mime::getproperty $token $p]"
}
}
#save attachment
set f [open $file w+]
mime::copymessage $token $f
close $f
#decode attachment
decode $file
incr totalAttachments
}
proc decode {file} {
global debug
if {![catch {set f [open $file r]}]} {
if {$debug} {textOut "\t\tFile info:"}
set l {}
set decode 0
set encoding text
set data {}
while {![eof $f]} {
gets $f l
set l $l
if {!$decode} {
if {$debug && [string length $l]} {textOut "\t\t\t$l"}
if {![string length $l]} {
#if {$encoding == "text"} { break }
set decode 1
} elseif {[lindex [string map {\" {}} $l] 0] == "Content-Transfer-Encoding:"} {
set encoding [lindex [string map {\" {}} $l] 1]
}
} else {
set data "[set data]\n$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
} elseif {$decode} {
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 maxDisp
if {$tkLoaded} {
.t configure -state normal
.t insert end "$text\n"
while {$maxDisp && [expr [lindex [split [.t index end] .] 0] - 1] > $maxDisp} {
.t delete 1.0 2.0
}
.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 $argvPavel Regarding the "decode" procedure, it looks like the base64 decoding functionality is already in the mime package. For me decoding an attachment worked out like this:
(after "initializing" a multipart MIME message from a file or string and enumerating its parts)
set mime_part [::mime::getbody $ptoken] # Takes care of decoding set f [open $file_name w+] # must switch off translation to write binary fconfigure $f -translation binary puts -nonewline $f $mime_part close $f