proc stega_get {image {all 0}} {
set w [image width $image]
set h [image height $image]
set n 0; set int 0; set res ""
for {set i 0} {$i<$h} {incr i} {
for {set j 0} {$j<$w} {incr j} {
foreach {r g b} [$image get $j $i] break
set int [expr {$int*8 + $r%2*4 + $g%2*2 + $b%2}]
if {[incr n]==3} {
if {!$all && $int==0} {return $res}
if {$int<32} {set int 32} ;# blank out control chars
append res [format %c $int]
set n 0; set int 0
}
}
}
set res
}On an untreated test image, this returns quite some gibberish. But now let's put a subtext into such an image. I restrict the character range to page 0 of the Unicode, because binary scan is so convenient, but works on bytes. Masking out the least-significant bit is done by bit-wise ANDing with the pattern 0xFE (i.e. all but the lsb set). proc stega_put {image text} {
set w [image width $image]
set h [image height $image]
set i 0; set j 0
foreach char [split $text\x0 ""] {
binary scan $char B* bits
set bits [split 0$bits ""] ;# prepend 0 to make it 9
foreach triplet [list [lrange $bits 0 2] \
[lrange $bits 3 5] [lrange $bits 6 8]] {
foreach {r g b} [$image get $j $i] {R G B} $triplet break
set r [expr {($r & 0xFE) + $R}]
set g [expr {($g & 0xFE) + $G}]
set b [expr {($b & 0xFE) + $B}]
set color [format #%02x%02x%02x $r $g $b]
$image put $color -to $j $i
if {[incr j]>=$w} {
if {[incr i]>=$h} return ;# truncate on image full
set j 0
}
}
}
}For transferring such an image "with a message", save it to a file. However, some file formats optimize away the least significant bit, losing the message. Writing in GIF format conserves the lsb, but may bail out because of "too many colors" (it appears to have a limited color table, and in worst case steganography makes eight times as many colors). Also, transparent pixels suddenly turn to black (or almost black), revealing that something is fishy with the image. JPEG drops the lsb. I found TIFF and PPM to work reliably, albeit uncompressed, so the file may get 6 times bigger than the original JPEG.thgr 2009-02-08 - Read about steganography on wikipedia [1] and wrote this litte tcl script to unravel the cat StenographyRecovered.png
which is hidden in StenographyOriginal.png 
package require Img
set sample "StenographyOriginal.png"
set src [image create photo -file $sample]
set w [image width $src]
set h [image height $src]
set trg [image create photo -width $w -height $h]
set trg2 [image create photo -width $w -height $h]
$trg blank
$trg2 blank
for {set y 0} {$y<$h} {incr y} {
for {set x 0} {$x<$w} {incr x} {
foreach {r g b} [$src get $x $y] {
# extract last two bits of each color channel
set R [expr {$r & 0x03}]
set G [expr {$g & 0x03}]
set B [expr {$b & 0x03}]
}
set color [format #%02x%02x%02x $R $G $B]
$trg put $color -to $x $y
# brighten 85 times
set color [format #%02x%02x%02x [expr $R*85] [expr $G*85] [expr $B*85]]
$trg2 put $color -to $x $y
}
}
$trg write unraveled.png -format png
$trg2 write unraveled_brightened.png -format pngaspect 2012-10-12: Here's a funny little demonstration of steganography I came up with today. It "hides" the message in a stream of text as follows:tHis MessaGE loOkS lIKe I'Ve wrITtEN it wITh A BROkeN sHIft keY. but you CAN sTILl REaD IT, BeCAUse You JUsT IgnoRE thE randOm capItaLs, treatiNg them aS 'nOisE'. BuT THeRe is ACtuAlLy A MesSAGe HIdden In IT: eVERy cAPiTAL LeTTer REPrESEntS a bINary 1, aNd EVEry lowER cAse leTTER a bInaRy 0. knowiNG tHis, YoU CAn cONstRuct a biT SeqUEncE, PAcK tHaT InTO ByteS aND Take The asciI value Of EACh One tO GEt A secREt mesSaGE. if yOU dIDn'T kNOw tHat it waS Here, yOu'D JUsT thinK i have a BRokEn shIFt key AnD IGnORE tHE cAPItalIsATIon.
#!/usr/bin/tclsh
#
lassign $argv secret carrier
puts "Encrypting $secret in $carrier"
foreach c [split $carrier {}] {
if {[string is alpha $c]} {
incr bitsAvail
}
}
set bitsNeeded [expr {[string length $secret]*8}]
if {$bitsNeeded > $bitsAvail} {
error "Not enough bits available: have $bitsAvail, need $bitsNeeded"
}
binary scan $secret B* bits
set bits [split $bits {}]
set upto 0
foreach c [split $carrier {}] {
if {[string is alpha $c]} {
if {($upto < [llength $bits]) && [lindex $bits $upto]} {
set c [string toupper $c]
} else {
set c [string tolower $c]
}
incr upto
}
append result $c
}
puts $resultDecryption is left as an excercise for the reader ..