Version 0 of tclhttpd gzip compression

Updated 2007-12-27 16:19:14 by fr

if {0} { 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

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 $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

---

category TclHttpd