## -*- tcl -*-
# ### ### ### ######### ######### #########
## Manipulate image orientation (rotation, flips along various axes).
## CPS style (request + completion callback).
## Fully parallel with the main tasks due to use of Threads (pool).
# ### ### ### ######### ######### #########
## Requisites
package require Tcl 8.5
package require Debug
package require snit
package require threadpool
package require uevent::job::queue
# ### ### ### ######### ######### #########
## Tracing
Debug off img/orientation
# ### ### ### ######### ######### #########
## Implementation
snit::type img::orientation {
# ### ### ### ######### ######### #########
## API
typemethod limit {n} {
$ourpool configure -limit $n
return
}
delegate typemethod {rotate ccw} to ourselves as {Schedule left}
delegate typemethod {rotate cw} to ourselves as {Schedule right}
delegate typemethod {rotate up} to ourselves as {Schedule up}
delegate typemethod {flip horizontal} to ourselves as {Schedule fliph}
delegate typemethod {flip vertical} to ourselves as {Schedule flipv}
delegate typemethod transpose to ourselves as {Schedule transpose}
delegate typemethod transverse to ourselves as {Schedule transverse}
typecomponent ourselves ;# == $type (see typeconstructor)
# ### ### ### ######### ######### #########
## Internal helpers
typemethod Schedule {operation imagefile future} {
Debug.img/orientation {[list $type Schedule $operation $imagefile $future]}
# This code is different from the img::geometry handler
# because here we modify the image, making order important. We
# cannot put the completion callbacks for one image together.
# But we can and do manage a queue per imagefile which injects
# the request into the threadpool not only in the proper
# order, but each also only after the previous request
# completed.
if {![info exists ourpending($imagefile)]} {
# No job queue for the image file yet. Create it.
set ourpending($imagefile) \
[uevent::job::queue ${type}::%AUTO% \
-gate-command [mytypemethod CanRunNext $imagefile]]
set ourlocked($imagefile) 0
}
# Put the operation into the existing queue, then wake it up,
# iff no job is currently running.
$ourpending($imagefile) put \
[mytypemethod Run $operation $imagefile $future]
if {$ourlocked($imagefile)} return
$ourpending($imagefile) wake
return
}
typemethod Run {operation imagefile future} {
Debug.img/orientation {[list $type Run $operation $imagefile $future]}
$ourpool put \
[list $operation $imagefile] \
[mytypemethod Done $operation $imagefile $future]
set ourlocked($imagefile) 1
return
}
typemethod CanRunNext {imagefile} {
return [expr {!$ourlocked($imagefile)}]
}
typemethod Done {operation imagefile future what detail} {
Debug.img/orientation {[list $type Done $operation $imagefile $future $what $detail]}
set ourlocked($imagefile) 0
# Run completion callback.
if {$what eq "ok"} {
$future return $detail
} else {
$future error $detail
}
# Wake the next job, iff there is any, and if no error occured.
if {$what eq "error"} {
$ourpending($imagefile) drain
} elseif {[$ourpending($imagefile) size]} {
$ourpending($imagefile) wake
}
return
}
# ### ### ### ######### ######### #########
## Initialization/Setup
typeconstructor {
Debug.img/orientation {$type typeconstructor ... Initialize internal threadpool}
set ourselves $type
set ourpool [threadpool ${type}::POOL \
-policy queue \
-setup {
package require fileutil
proc up {input} {
# Use jhead's facilities for auto-rotation to set
# the image upright. This handles any stored
# thumbnail automatically.
exec jhead -autorot $input
return
}
proc left {input} { DO $input -rotate 270 }
proc right {input} { DO $input -rotate 90 }
proc fliph {input} { DO $input -flip horizontal }
proc flipv {input} { DO $input -flip vertical }
proc transpose {input} { DO $input -transpose }
proc transverse {input} { DO $input -transverse }
proc DO {input args} {
# Using jhead and jpegtran to transform loss-lessly,
# and keeping the thumbnail in sync
# NOTE: This kills a stored thumbnail.
if {[catch {
set r [fileutil::tempfile imgorient_res_]
set s [fileutil::tempfile imgorient_thumbres_]
set t [fileutil::tempfile imgorient_thumb_]
exec jpegtran -copy all {*}$args $input > $r
exec jhead -st $t $r
exec jpegtran -copy all {*}$args $t > $s
exec jhead -rt $s $r
file rename -force $r $input
file delete $s $t
}]} {
return -code error $::errorInfo
}
return
}
}]
return
}
# ### ### ### ######### ######### #########
## State
typecomponent ourpool ; # Thread pool handling the orientation jobs.
typevariable ourpending -array {} ; # Map for the per-image queues.
typevariable ourlocked -array {} ; # Map for the per-image queue locks.
# ### ### ### ######### ######### #########
## Configuration
pragma -hasinstances no ; # singleton
pragma -hastypeinfo no
pragma -hastypedestroy no
pragma -hasinfo no
pragma -simpledispatch yes
##
# ### ### ### ######### ######### #########
}
# ### ### ### ######### ######### #########
## Ready
package provide img::orientation 0.1