source with encoding

For those having source files containing data not encoded in the system encoding (and thus being not recognized correct by source), this small helper proc may help you:

DKF: Note that source from Tcl 8.5 onwards has a -encoding option.


 proc encsource {source_file encoding} {    
     if {![catch {open $source_file r} fid]} {
       if {![catch {fconfigure $fid -encoding $encoding} msg]} {
         set script [read $fid]
         catch {close $fid}
       } else {
         # make sure channel gets closed
         catch {close $fid}
         return -code error "unknown encoding \"$encoding\""
       }
     } else {
         # return error message similar to source cmd
         return -code error "couldn't read file \"$source_file\": no such file or directory"
     } 
     # not sure if this has to be catched as well to propagate the error code to the caller
     # to imitate the original source cmds behaviour.
     uplevel 1 $script
 }

 Usage:
   % encsource "test.tcl" utf-8

EKB May 8, 2005 -- I've used the "encsource" proc to read in user-created input files. The input files are in Tcl, and the user might write them in any encoding. To allow for any possible encoding, I allow the user to start the file with an "encoding directive" that looks something like

  #ENC cp1252

The encoding directive has to be the first line of the file. When the file is read, it is first opened in the default encoding and the first line is scanned. If it is an encoding directive, the encoding is set using it, the file is closed, and then reopened using the proper encoding. (This is how web browsers do it -- the characters to specify the encoding should be readable in the default encoding, even if the rest of the file isn't.)

Here's the code I use to do this (the variable defcharset is set to a default encoding and the variable encdir is set to the path that holds the encoding files -- this shouldn't be needed if the user has Tcl/Tk installed, but I distribute this as a freewrapped application):

 # Find out if there is an encoding directive
 set charset $defcharset
 if {[catch {open $currfnamefull r} fhndl]} {
    tk_messageBox -icon error -message "Couldn't open script \"$currfname\": $fhndl"
    return
 } else {
    set firstline [gets $fhndl]
    if {[regexp -- "^#ENC\\s+\(\\S+\)$" $firstline wholeline enc] == 1} {
       set charset [file join $encdir $enc]
    }
    close $fhndl
 }
 if [catch {encsource $tempfname $charset} err] {
   # Error - take action
 } else {
   # All is well!
 }


Peter K: I had to develop Tcl code for Windows (shudder) and used existing code on the Mac. Since I had to do a lot of transferring between Mac and cp1252, I wrote a little script to convert files and folders between all possible encodings. Here is the code (encoded in cp1252):

    #############################################################################
    # Visual Tcl v1.20 Project
    #
    #################################
    # GLOBAL VARIABLES
    #
    global Kodierung  ; set Kodierung  3
    global Kodierung1 ; set Kodierung1 cp1252
    global Kodierung2 ; set Kodierung2 macRoman
    global Eingabe ; set Eingabe ""
    global Ausgabe ; set Ausgabe ""
    global Auswahl ; set Auswahl [encoding names]
    #################################
    # USER DEFINED PROCEDURES
    #
    proc {main} {argc argv} {

    }

    #
    #
    #
    proc {Window} {args} {
    #
        set cmd [lindex $args 0]
        set name [lindex $args 1]
        set newname [lindex $args 2]
        set rest [lrange $args 3 end]
        if {$name == "" || $cmd == ""} {return}
        if {$newname == ""} {
            set newname $name
        }
        set exists [winfo exists $newname]
        switch $cmd {
            show {
                if {$exists == "1" && $name != "."} {wm deiconify $name; return}
                if {[info procs vTclWindow(pre)$name] != ""} {
                    eval "vTclWindow(pre)$name $newname $rest"
                }
                if {[info procs vTclWindow$name] != ""} {
                    eval "vTclWindow$name $newname $rest"
                }
                if {[info procs vTclWindow(post)$name] != ""} {
                    eval "vTclWindow(post)$name $newname $rest"
                }
            }
            hide    { if $exists {wm withdraw $newname; return} }
            iconify { if $exists {wm iconify $newname; return} }
            destroy { if $exists {destroy $newname; return} }
        }
    }

    #################################
    # VTCL GENERATED GUI PROCEDURES
    #

    proc vTclWindow. {base} {
        if {$base == ""} {
            set base .
        }
        ###################
        # CREATING WIDGETS
        ###################
        wm focusmodel $base passive
        wm geometry $base 1x1+25+65
        wm maxsize $base 817 594
        wm minsize $base 1 1
        wm overrideredirect $base 0
        wm resizable $base 1 1
        wm withdraw $base
        wm title $base "Wish"
        ###################
        # SETTING GEOMETRY
        ###################
    }

    proc vTclWindow.dialog {base} {
    global Kodierung
    global Kodierung1
    global Kodierung2
    global Eingabe
    global Ausgabe
    global Auswahl
    #
        if {$base == ""} {
            set base .dialog
        }
        if {[winfo exists $base]} {
            wm deiconify $base; return
        }
        ###################
        # CREATING WIDGETS
        ###################
        toplevel $base -class Toplevel -relief groove 
        wm focusmodel $base passive
        wm geometry $base 417x338+101+123
        wm maxsize $base 817 594
        wm minsize $base 1 1
        wm overrideredirect $base 0
        wm resizable $base 1 1
        wm deiconify $base
        wm title $base "Translate Encodings"
        set Verschiebung 1
    #
        frame $base.eingabe \
            -borderwidth 1 -height 30 -relief ridge -width 30 
        entry $base.eingabe.03 \
            -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \
            -textvariable Eingabe -justify center -width 8 -state normal
        button $base.such1 -text "Source File:" \
            -command "Datei_lesen" -height 28
        button $base.such2 -text "Source Directory:" \
            -command "Verzeichnis_lesen" -height 28
    #
    # Das Aufklapp-MenŸ anlegen
    #
        menubutton $base.m1 \
            -menu $base.m1.sub -textvariable Kodierung1 -direction flush \
            -borderwidth 2 -indicatoron 1 -padx 8
        menu $base.m1.sub -tearoff 0
        foreach Eintrag $Auswahl {
            $base.m1.sub add radiobutton \
              -variable Kodierung1 -value $Eintrag -label $Eintrag
        }
        radiobutton $base.b0 \
            -text "MacRoman -> iso8859-1" -cursor left_ptr -anchor w \
            -variable Kodierung -value 0 \
            -command {set Kodierung1 MacRoman; set Kodierung2 iso8859-1}
        radiobutton $base.b1 \
            -text "iso8859-1 -> MacRoman" -cursor left_ptr -anchor w \
            -variable Kodierung -value 1 \
            -command {set Kodierung1 iso8859-1; set Kodierung2 MacRoman}
        radiobutton $base.b2 \
            -text "MacRoman -> cp1252" -cursor left_ptr -anchor w \
            -variable Kodierung -value 2 \
            -command {set Kodierung1 MacRoman; set Kodierung2 cp1252}
        radiobutton $base.b3 \
            -text "cp1252 -> MacRoman" -cursor left_ptr -anchor w \
            -variable Kodierung -value 3 \
            -command {set Kodierung1 cp1252; set Kodierung2 MacRoman}
        menubutton $base.m2 \
            -menu $base.m2.sub -textvariable Kodierung2 -direction flush \
            -borderwidth 2 -indicatoron 1 -padx 8
        menu $base.m2.sub -tearoff 0
        foreach Eintrag $Auswahl {
            $base.m2.sub add radiobutton \
              -variable Kodierung2 -value $Eintrag -label $Eintrag
        }
    #
        frame $base.ausgabe \
            -borderwidth 1 -height 30 -relief ridge -width 30 
        entry $base.ausgabe.03 \
            -font -Adobe-Helvetica-Medium-R-Normal-*-*-120-*-*-*-*-*-* \
            -textvariable Ausgabe -justify center -width 8 -state disabled
        button $base.such3 -text "Target File:" \
            -command "Datei_schreiben" -height 28
        button $base.such4 -text "Target Directory:" \
            -command "Verzeichnis_schreiben" -height 28
        message $base.m -width 377 \
            -text "Warning: Files will be overwritten without warning!"
        bind $base <Return> {Schreiben $Ausgabe}
    ###################
    # SETTING GEOMETRY
    ###################
        place $base.eingabe \
            -x 5 -y 45 -width 408 -height 36
        grid columnconf $base.eingabe 0 -weight 1
        grid rowconf $base.eingabe 0 -weight 1
        grid $base.eingabe.03 \
            -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky nesw 
        place $base.such1 \
            -x  10 -y  16 -width 190 -height 28
        place $base.such2 \
            -x 220 -y  16 -width 190 -height 28
        place $base.m1 \
            -x  20 -y  95 -width 320 -height 29
        place $base.b0 \
            -x  20 -y  138 -anchor w
        place $base.b1 \
            -x  210 -y  138 -anchor w
        place $base.b2 \
            -x  20 -y  168 -anchor w
        place $base.b3 \
            -x  210 -y  168 -anchor w
        place $base.m2 \
            -x  20 -y 185 -width 320 -height 29
        place $base.ausgabe \
            -x   5 -y 255 -width 408 -height 36
        grid columnconf $base.ausgabe 0 -weight 1
        grid rowconf $base.ausgabe 0 -weight 1
        grid $base.ausgabe.03 \
            -column 0 -row 0 -columnspan 1 -rowspan 1 -sticky nesw 
        place $base.such3 \
            -x  10 -y 226 -width 190 -height 28
        place $base.such4 \
            -x 220 -y 226 -width 190 -height 28
        place $base.m \
            -x 20 -y 310 -anchor w
    }

    #
    #
    #
    proc fileDialog { w ent operation art } {
        global Namen
      #   Type names        Extension(s)  Mac File Type(s)
      #
      #---------------------------------------------------------
      set types {
        {"All files"        *               }
        {"Text files"       {}          TEXT}
        {"Text files"       {.txt}          }
      }
      if {$operation == "open"} {
            set file [tk_getOpenFile -filetypes $types -parent $w]
      } elseif {$operation == "viele"} {
            set file [tk_chooseDirectory -parent $w]
      } elseif {$operation == "save"} {
            set file [tk_getSaveFile -parent $w -initialfile $Namen]
      } else {
            set file [tk_chooseDirectory -parent $w]
      }
      if [string compare $file ""] {
            if {$art == "entry"} {
                $ent delete 0 end
                $ent insert 0 "$file"
                $ent xview end
            } else {
                set file [join [list $art Datei] {}]
            }
        }
        return $file
    }

    #
    #
    #
    proc Datei_lesen {} {
        global Eingabe
        global Namen
    #
        set Eingabe "[fileDialog .dialog .dialog.eingabe.03 open entry]"
        Einlesen
        set Namen [file tail $Eingabe]
        update
    }

    #
    #
    #
    proc Verzeichnis_lesen {} {
        global Dateiliste
    #
        set Eingabe "[fileDialog .dialog .dialog.eingabe.03 viele entry]"
        set Liste [glob -nocomplain [file join $Eingabe "*"]]
        set Dateiliste   {}
        foreach f $Liste {
            if { ![file isdirectory $f] } {
                lappend Dateiliste $f
            }
        }
    }

    #
    #
    #
    proc Datei_schreiben {} {
        global Ausgabe
        global tcl_platform
    #
        set Ausgabe "[fileDialog .dialog .dialog.ausgabe.03 save entry]"
        Schreiben
        if {$tcl_platform(platform) == "macintosh"} {
            file attributes $Ausgabe -creator "ALFA" -type "TEXT"
        }
    }

    #
    #
    #
    proc Verzeichnis_schreiben {} {
        global Eingabe
        global Ausgabe
        global Dateiliste
        global tcl_platform
    #
        set Ziel "[fileDialog .dialog .dialog.ausgabe.03 viele entry]"
        foreach f $Dateiliste {
            set Eingabe $f
            Einlesen
            set Namen [file tail $Eingabe]
            set Ausgabe [file join $Ziel $Namen]
            Schreiben
            if {$tcl_platform(platform) == "macintosh"} {
                file attributes $Ausgabe -creator "ALFA" -type "TEXT"
            }
        }
    }

    #
    #
    #
    proc Einlesen {} {
        global Kodierung1
        global Eingabe
        global Datei
    #
        encoding system $Kodierung1
    #
        if [catch {open "$Eingabe" r} fileID] {
            tk_messageBox .error -title "Fehler beim …ffnen der Datei" \
              -message "Datei $Eingabe geht nicht auf" -icon error -type ok
        } else {
            set Datei [split [read $fileID] \n]
            close $fileID
        }
    }

    #
    #
    #
    proc Schreiben {} {
        global Kodierung2
        global Ausgabe
        global Datei
    #
        encoding system $Kodierung2
    #
        if [catch {open "$Ausgabe" w} fileID] {
            tk_messageBox .error -title "Fehler beim …ffnen der Datei" \
              -message "Datei $Ausgabe geht nicht auf" -icon error -type ok
        } else {
            foreach Zeile $Datei {
                puts $fileID $Zeile
            }
            close $fileID
        }
    }

    Window show .
    Window show .dialog
    console hide
    main $argc $argv