tclhttpd gzip compression

The current tclsh 8.6 has the zlib command available. Following example generates a demo page with charset=utf-8 and content-encoding gzip. To use Deflate compression just replace the two appearances of gzip in the body of the procedure with deflate.

For use in older versions see a standalone version of zlib command

# vim: encoding=utf-8:
proc gzip {{x {some repeated text<br>}} {n 10}} {
   global Httpd
   upvar #0 Httpd$Httpd(currentSocket) data
   set text "<!DOCTYPE html><html><head>\
   </head><body><p>"
   foreach i {0 1 2 3 4 5 6 7 8 9 A B C D E F} {
      append text [subst \\u250$i]
   }
   append text <br>
   set middot \u2022
   set uni [string repeat $middot 10]
   append text $uni
   append text äöüéîâ
   append text <br>
   append text [string repeat $x $n]
   append text </html>
   set bin [encoding convertto utf-8 $text]
   set blen [string bytelength $bin]
   set res [zlib gzip $bin]
   set rlen [string length $res]
   append rlen .
   set data(headers) [list Content-Encoding: gzip Cache-Control: none ratio: [format %.2f [expr {$rlen/$blen}]]]
   set ::gzip "text/html; charset=utf-8"
   return $res
}
Direct_Url /gzip ::gzip

fr experimental: How to serve a pre-compressed html-file with tclhttpd

Place an example file "file.html" in document-root, which will be cached and delivered with gzip encoding.

Place the code below in custom/gz.tcl.

Place a file file.html in document-root directory

Start the server: wish84.exe bin\httpd.tcl -library custom -debug 1

Point your browser to http://localhost:8015/gz/file.htm

Package gzip from http://www.mail-archive.com/[email protected]/msg04572/gzip.tcl


package provide gzip 1.0

package require Trf 2.0

namespace eval gzip {
    variable crc
    array set crc {}

    variable size
    array set size {}

    proc open {filestream {compression_level 6}} {
        variable crc
        variable size

        # just in case they've forgotten
        fconfigure $filestream -translation binary

        # initialize the crc and size variables for this stream
        set crc($filestream)  0
        set size($filestream) 0

        # write the gzip header (minimal form)
        puts -nonewline $filestream \
                [binary format H8iH4 1f8b0800 [clock seconds] 0003]

        # turn zip compression on for the stream
        zip -attach $filestream -mode compress -level $compression_level \
                -nowrap 1

        # attach a crc calculator to the stream
        crc-zlib -attach $filestream -mode transparent \
                -write-destination gzip::crc($filestream) \
                -write-type variable

        # and a size calculator
        transform -attach $filestream \
                -command [namespace code [list filesize $filestream]]
    }

    proc close {filestream} {
        variable crc
        variable size

        # unstack the three channel handlers we've added
        unstack $filestream
        unstack $filestream
        unstack $filestream

        # finish off the stream with the crc and original size
        puts -nonewline $filestream $crc($filestream)
        puts -nonewline $filestream [binary format i $size($filestream)]

        unset crc($filestream)
        unset size($filestream)
    }

   proc filesize {stream op buffer} {
       variable size

       # this is called to calculate the data size
       # the only op we're interested in is "write"

       switch -exact -- $op {
           write {
               incr size($stream) [string length $buffer]
           }
       }
       set buffer
   }
}
proc JH_gzip {htdocs_file} {
    set path [file dirname [info script]]
    set path [file dirname $path]
    set path [file join $path htdocs]
    set filename [file join $path $htdocs_file]
    set gz $filename.gz
    if {![file exists $gz]} {
        package require gzip; # in turn requires Trf
        set ifid [open $filename]
        set ofid [open $gz w]
        gzip::open $ofid; # actually attaches transforms, writes header
        fcopy $ifid $ofid
        gzip::close $ofid; # detaches transforms, writes crc trailer
        close $ifid
        close $ofid
    }
    set in [open $gz r]
    fconfigure $in -translation binary
    set ::compressed_file_cache [read $in]
    close $in
}
JH_gzip file.html
set ::tentative ""
set body [info body HttpdRespondHeader]
set pattern {^\s*append reply \"Content-Type: \$type\" \\n}
regsub -line $pattern [info body HttpdRespondHeader] \
    {if {[string equal $::tentative gz]} {set ::tentative "";append reply "Content-Type: text/html" \n;append reply "Content-Encoding: gzip" \n } else {append reply "Content-Type: $type" \n}} body
proc HttpdRespondHeader [info args HttpdRespondHeader] $body
proc ::tentative {} {
    set ::tentative gz
    return $::compressed_file_cache
}

Direct_Url /gz/file.html ::tentative