[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 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 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 $argv ---- [Category Binary Data] - [Category File]