Updated 2008-04-09 13:18:04 by escargo

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
      #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
            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
      #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
   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]
   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]
      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

[Pavel] 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

Category Binary Data - Category File