This code implements a quick and dirty image server for [tclhttpd]. It is was intented to allow hassle free deployment of your digital photos. It runs in 2 modes. Mode 1 shows a table of thumb nails of which you can click on an download the full image. Mode 2 performs a slide show using a JavaScript(cough cough) template. Other features include traversal through catalogs, auto thumbnail generation, and a not completed album file which will include presentation info for the current catalog being viewed.
This code is only tested on an Windows XP machine. Place this code in your Document Root/Custom directory. Some modifications will be needed. I'll fix it up later. Oops you need to find a folder image or remove it from the code. Good luck !
Art
art@rain.org
----
======
# $Id: 4371,v 1.3 2002-10-23 08:01:02 jcw Exp $#
# This is my Tcl http image server.
if { ! [info exists IserverInit] } {
Url_PrefixInstall /images [list ImageServerDomain /images]
set IserverInit 1
}
package require Img
proc ImageServerDomain {prefix sock suffix} {
upvar #0 Httpd$sock data
# fix this kludge
regsub -all {%20} $prefix { } prefix
regsub -all {%20} $suffix { } suffix
global Config
#make prefix relative
regsub {^/} $suffix {} suffix
set fullRelativePath [file join $prefix $suffix] ; # (eg. /image/dirA/dirB/DirC )
regsub {^/} $fullRelativePath {} pfx
set realdir [file join $Config(docRoot) $pfx]
if { ! [file isdirectory $realdir] } {
# it appears that all the images needed to populate a html page all call this
# routine enter this spot here to return image data
Httpd_ReturnFile $sock image/JPEG $realdir
return
}
set title [file tail $realdir]
set usePresentation 0
set srcImages,names {}
set {srcImages,thumbs} {}
set srcImages,titles {}
set sub,dirs {}
# Generate page header
set html "Album $title \n"
#--- This is a control file in a album directory
# it has things like a list of files not to display , titles for image, to be defined later...
global album
array set album {skipImages {}}
set albumFile [file join $realdir album]
if { [file exists $albumFile] } {
set f [open $albumFile r]
set Data [read $f]
close $f
foreach line [split $Data \n] {
array set album $line
}
}
set thumbdir [file join $realdir thumbs]
if { ! [file exists $thumbdir] } { file mkdir $thumbdir }
## -- This populates: srcImages,names ; srcImages,titles ; lappend sub,dirs
## -- and created thumbnails if they do not exist
foreach x [glob $realdir/*] {
if { [lsearch $album(skipImages) [file tail $x]] >= 0 } { continue }
if { [string compare [string tolower [file extension $x]] ".jpg"] == 0 } {
lappend srcImages,names $x
lappend srcImages,titles [file tail $x]
set thumbfile [file join $thumbdir [file tail $x] ]
lappend srcImages,thumbs $thumbfile
if { ! [file exists $thumbfile ] || ( [file mtime $x] > [file mtime $thumbfile] ) } {
set src [image create photo -file $x -format jpeg]
set wi [image width $src]
set he [image height $src]
set dest [image create photo -width 128 -height 128]
$dest copy $src -subsample [expr $wi/128] [expr $he/128]
image del $src
$dest write $thumbfile -format jpeg
image del $dest
}
} elseif { [file isdirectory $x] && [string compare [file tail $x] "thumbs"] != 0 } {
lappend sub,dirs $x
}
}
append html "
"
if { [string compare [file dirname $fullRelativePath] "/"] != 0 } {
append html "
"
if { [llength ${srcImages,thumbs} ] > 0 } {
append html "
"
}
set row 0
set col 1
foreach thumbFile ${srcImages,thumbs} localSrcFileName ${srcImages,names} {
set hrefImg [file join $fullRelativePath [file tail $localSrcFileName] ]
set srcImg [file join $fullRelativePath thumbs [file tail $thumbFile] ]
if { [expr int( fmod( $col,4)) ] == 0 } { append html "
" }
append html "
"
incr col
}
if { [llength ${srcImages,thumbs} ] > 0 } {
append html "
"
}
Httpd_ReturnData $sock text/html $html
}
proc isJpeg {afile } {
if { [string compare [string tolower [file extension $afile]] ".jpg"] == 0 } {
if { [file exists $afile] } {
return 1
}
}
return 0
}
# $Id: 4371,v 1.3 2002-10-23 08:01:02 jcw Exp $#
if { ! [info exists SlideInit] } {
Direct_Url /slide ::slide::
set SlideInit 1
}
namespace eval ::slide {
variable x [clock format [clock seconds]]
}
# ::hello::/ --
#
# This implements /hello/
proc ::slide::/ {args} {
return "Hello, World!"
}
# ::hello::/ --
#
# This implements /hello/
# Need to pass in the directory name and not the files
# or do a %s encoding of spaces in names when passing in mike vonplinksis files
# put mini pictures in the catalog
# title each picture as it is drawn
# when slide show hits end. the back button needs to be pressed twice
# table for control buttons seperate from table from other controls
# somehow put in a toolbarless window
# raise the window if exists already
# verify the javascript
# consider how to obfuscate the code
# fix aspect ratio change of the image
proc ::slide::/go {args} {
variable x
set url [lindex $args 1]
set files [lindex $args 3]
set files [join $files ,]
# regsub -all {,} $files "\",\"http://68.6.44.242:8085$url/" files
# set files \"http://68.6.44.242:8085$url/$files\"
regsub -all {,} $files "\",\"$url/" files
set files \"$url/$files\"
set tmp $::data
regsub -all {theLen} $tmp $files tmp
return $tmp
}
set data {
}
======
<> Example | Internet | Tclhttpd
![](\"/folder.gif\")
[file tail $x]"
}
append html "