mime::getbody (public)

 mime::getbody token [ args... ]

Defined in packages/acs-tcl/tcl/tcllib-doc-procs.tcl

Read the body of a Tcllib MIME token. The -decode option requests transfer decoding; -command enables callback-based delivery.

Parameters:

token (required)

MIME token to read.

Returns:

The body, or the final callback result when -command is used.

See Also:

• https://core.tcl-lang.org/tcllib/doc/trunk/embedded/md/tcllib/files/modules/mime/mime.md

Partial Call Graph (max 5 caller/called nodes):

Testcases:

No testcase defined.

Source code:

    global errorCode errorInfo
    # FRINK: nocheck
    variable $token
    upvar 0 $token state

    set decode 0
    if {[set pos [lsearch -exact $args -decode]] >= 0} {
        set decode 1
        set args [lreplace $args $pos $pos]
    }

    array set options [list -command [
        list mime::getbodyaux $token] -blocksize 4096]
    array set options $args
    if {$options(-blocksize) < 1} {
        error "-blocksize expects a positive integer, not $options(-blocksize)"
    }

    set code 0
    set ecode {}
    set einfo {}

    switch -- $state(value)/$state(canonicalP) {
        file/0 {
            set fd [open $state(file) RDONLY]

            set code [catch {
                fconfigure $fd -translation binary
                seek $fd [set pos $state(offset)] start
                set last [expr {$state(offset) + $state(count) - 1}]

                set fragment {}
                while {$pos <= $last} {
                    if {[set cc [
                        expr {($last - $pos) + 1}]] > $options(-blocksize)} {
                        set cc $options(-blocksize)
                    }
                    incr pos [set len [
                        string length [set chunk [read $fd $cc]]]]
                    switch -exact -- $state(encoding) {
                        base64
                            -
                        quoted-printable {
                            if {([set x [string last \n $chunk]] > 0)  && ($x + 1 != $len)} {
                                set chunk [string range $chunk 0 $x]
                                seek $fd [incr pos [expr {($x + 1) - $len}]] start
                            }
                            set chunk [
                                $state(encoding) -mode decode -- $chunk]
                        }
                        7bit - 8bit - binary - {} {
                            # Bugfix for [#477088]
                            # Go ahead, leave chunk alone
                        }
                        default {
                            error "Can't handle content encoding \"$state(encoding)\""
                        }
                    }
                    append fragment $chunk

                    set cc [expr {$options(-blocksize) - 1}]
                    while {[string length $fragment] > $options(-blocksize)} {
                        uplevel #0 $options(-command) [
                            list data [string range $fragment 0 $cc]]

                        set fragment [
                            string range $fragment $options(-blocksize) end]
                    }
                }
                if {[string length $fragment] > 0} {
                    uplevel #0 $options(-command) [list data $fragment]
                }
            } result]
            set ecode $errorCode
            set einfo $errorInfo

            catch {close $fd}
        }

        file/1 {
            set fd [open $state(file) RDONLY]

            set code [catch {
                fconfigure $fd -translation binary

                while {[string length [
                    set fragment [read $fd $options(-blocksize)]]] > 0} {
                        uplevel #0 $options(-command) [list data $fragment]
                    }
            } result]
            set ecode $errorCode
            set einfo $errorInfo

            catch {close $fd}
        }

        parts/0
            -
        parts/1 {
            error "MIME part isn't a leaf"
        }

        string/0
            -
        string/1 {
            switch -- $state(encoding)/$state(canonicalP) {
                base64/0
                    -
                quoted-printable/0 {
                    set fragment [
                        $state(encoding) -mode decode -- $state(string)]
                }

                default {
                    # Not a bugfix for [#477088], but clarification
                    # This handles no-encoding, 7bit, 8bit, and binary.
                    set fragment $state(string)
                }
            }

            set code [catch {
                set cc [expr {$options(-blocksize) -1}]
                while {[string length $fragment] > $options(-blocksize)} {
                    uplevel #0 $options(-command) [
                        list data [string range $fragment 0 $cc]]

                    set fragment [
                        string range $fragment $options(-blocksize) end]
                }
                if {[string length $fragment] > 0} {
                    uplevel #0 $options(-command) [list data $fragment]
                }
            } result]
            set ecode $errorCode
            set einfo $errorInfo
        }
        default {
            error "Unknown combination \"$state(value)/$state(canonicalP)\""
        }
    }

    set code [catch {
        if {$code} {
            uplevel #0 $options(-command) [list error $result]
        } else {
            uplevel #0 $options(-command) [list end]
        }
    } result]
    set ecode $errorCode
    set einfo $errorInfo

    if {$code} {
        return -code $code -errorinfo $einfo -errorcode $ecode $result
    }

    if {$decode} {
        array set params [mime::getproperty $token params]

        if {[info exists params(charset)]} {
            set charset $params(charset)
        } else {
            set charset US-ASCII
        }

        set enc [reversemapencoding $charset]
        if {$enc ne {}} {
            set result [::encoding convertfrom $enc $result]
        } else {
            return -code error "-decode failed: can't reversemap charset $charset"
        }
    }

    return $result

XQL Not present:

Generic, PostgreSQL, Oracle