# showimage.tcl (c) 2012 Fermion <fermion_ph@jabber.ru>
# Show images from URLs in a Tkabber chat window
#
# TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
# 0. You just DO WHAT THE FUCK YOU WANT TO.
#
# TODO: fix multiple urls error, imagemagick image resizing

package require http
package require msgcat

namespace eval showimage {
    variable tmpdir [pwd]
    variable null ""
    switch -- $tcl_platform(platform) {
         windows {
             catch { set tmpdir $::env(TMP) }
             catch { set tmpdir $::env(TEMP) }
             set null "2>NUL"
         }
         unix {
             set tmpdir "/tmp"
             catch { set tmpdir $::env(TMPDIR) }
             set null "2>/dev/null"
         }
         macintosh {
             # In case when someone would like to implement it
             set tmpdir $::env(TRASH_FOLDER)
             return
         }
    }

    custom::defgroup Plugins "Plugins options." -group Tkabber

    custom::defgroup ShowImage "ShowImage plugin options." -group Plugins

    custom::defvar options(showimage_width) 0  \
    "Max image width." \
    -group ShowImage -type integer
    custom::defvar options(showimage_height) 0  \
    "Max image height." \
    -group ShowImage -type integer
}

proc showimage::draw_image_text {chatid from type body x} {
    variable tmpdir
    variable options

    ### Before nickname
    if {[chat::is_our_jid $chatid $from]} {
         set tag me
    } else {
         set tag they
    }

    set connid [chat::get_connid $chatid]
    set chatw [chat::chat_win $chatid]
    set nick [chat::get_nick $connid $from $type]
    set cw [chat::winid $chatid]

    $chatw insert end "<$nick>" [list $tag NICK-$nick] " "
    ###

    # Find all urls to images in a message
    foreach {str path ext} [regexp -all -inline {(http://.*\.)(jpg|png|gif)} $body] {
        set imageurl $str

        set dirname [file join $tmpdir showimage]
        file mkdir $dirname
        set fname [file join $dirname out.jpg]

        if {[catch {fetch $imageurl $fname} err]} {
           debugmsg showimage "Got fetch error: $err"
        }

        set image_error 0
        if {[catch {set src [image create photo -file $fname]} err]} {
            debugmsg showimage "Got create image error: $err"
            set image_error 1
        }

        if {$image_error == 0} {
            # Replace url from the body
            string map {$imageurl ""} $body

            # Resize image if necessary
            if {$options(showimage_width) > 0 || $options(showimage_height) > 0} {
                set $src [resize $src $options(showimage_width) $options(showimage_height)]
            }

            # Insert image
            $chatw insert end "\n"
            $chatw image create end -image $src
            $chatw insert end "\n"
        }
    }

    $chatw mark set MSGLEFT "end - 1 char"
    $chatw mark gravity MSGLEFT left

    if {[cequal $type groupchat]} {
         set myjid [chat::our_jid $chatid]
         set mynick [chat::get_nick $connid $myjid $type]

         ::richtext::property_add mynick $mynick
         ::richtext::render_message $chatw $body ""
    } else {
         ::richtext::render_message $chatw $body ""
    }

    $chatw tag add MSG-$nick MSGLEFT "end - 1 char"

    if {![catch {::plugins::mucignore::is_ignored $connid $from $type} ignore] && \
        $ignore != ""} {
         $chatw tag add $ignore {MSGLEFT linestart} {end - 1 char}
    }

    return stop
}

hook::add draw_message_hook [namespace current]::showimage::draw_image_text 86

proc showimage::fetch {url fname} {
    set Stat "skip"

    set f [open $fname w]
    fconfigure $f -translation binary
    set imgtok [http::geturl "$url" -binary true -channel $f]
    set Stat [::http::status $imgtok]
    flush $f
    close $f

    http::cleanup $imgtok
}

# Very slow. Tcl is not fast enough by itself to process images
proc showimage::resize {src newx newy {dest ""} } {

    set mx [image width $src]
    set my [image height $src]

    if { "$dest" == ""} {
         set dest [image create photo]
    }

    # Calculate other side if one of sides is not set
    if {$newy == 0} {
        set newy [expr {$my*$newx / $mx}]
    }
    if {$newx == 0} {
        set newx [expr {$mx*$newy / $my}]
    }

    if {[expr {$my*$my}] <= [expr {$newx*$newy}]} {
        return $src
    }

    $dest configure -width $newx -height $newy

    # Check if we can just zoom using -zoom option on copy
    if { $newx % $mx == 0 && $newy % $my == 0} {

         set ix [expr {$newx / $mx}]
         set iy [expr {$newy / $my}]
         $dest copy $src -zoom $ix $iy
         return $dest
    }

    set ny 0
    set ytot $my

    for {set y 0} {$y < $my} {incr y} {

         #
         # Do horizontal resize
         #
         foreach {pr pg pb} [$src get 0 $y] {break}

         set row [list]
         set thisrow [list]

         set nx 0
         set xtot $mx

         for {set x 1} {$x < $mx} {incr x} {

            # Add whole pixels as necessary
            while { $xtot <= $newx } {
                lappend row [format "#%02x%02x%02x" $pr $pg $pb]
                lappend thisrow $pr $pg $pb
                incr xtot $mx
                incr nx
            }

            # Now add mixed pixels
            foreach {r g b} [$src get $x $y] {break}

            # Calculate ratios to use
            set xtot [expr {$xtot - $newx}]
            set rn $xtot
            set rp [expr {$mx - $xtot}]

            # This section covers shrinking an image where
            # more than 1 source pixel may be required to
            # define the destination pixel
            set xr 0
            set xg 0
            set xb 0

            while { $xtot > $newx } {
                incr xr $r
                incr xg $g
                incr xb $b

                set xtot [expr {$xtot - $newx}]
                incr x
                foreach {r g b} [$src get $x $y] {break}
            }

            # Work out the new pixel colours
            set tr [expr {int( ($rn*$r + $xr + $rp*$pr) / $mx)}]
            set tg [expr {int( ($rn*$g + $xg + $rp*$pg) / $mx)}]
            set tb [expr {int( ($rn*$b + $xb + $rp*$pb) / $mx)}]

            if {$tr > 255} {set tr 255}
            if {$tg > 255} {set tg 255}
            if {$tb > 255} {set tb 255}

            # Output the pixel
            lappend row [format "#%02x%02x%02x" $tr $tg $tb]
            lappend thisrow $tr $tg $tb
            incr xtot $mx
            incr nx

            set pr $r
            set pg $g
            set pb $b
         }

         # Finish off pixels on this row
         while { $nx < $newx } {
            lappend row [format "#%02x%02x%02x" $r $g $b]
            lappend thisrow $r $g $b
            incr nx
         }

         #
         # Do vertical resize
         #
         if {[info exists prevrow]} {

            set nrow [list]

            # Add whole lines as necessary
            while { $ytot <= $newy } {

                $dest put -to 0 $ny [list $prow]

                incr ytot $my
                incr ny
            }

            # Now add mixed line
            # Calculate ratios to use
            set ytot [expr {$ytot - $newy}]
            set rn $ytot
            set rp [expr {$my - $rn}]

            # This section covers shrinking an image
            # where a single pixel is made from more than
            # 2 others.  Actually we cheat and just remove
            # a line of pixels which is not as good as it should be
            while { $ytot > $newy } {

                set ytot [expr {$ytot - $newy}]
                incr y
                continue
            }

            # Calculate new row
            foreach {pr pg pb} $prevrow {r g b} $thisrow {

                set tr [expr {int( ($rn*$r + $rp*$pr) / $my)}]
                set tg [expr {int( ($rn*$g + $rp*$pg) / $my)}]
                set tb [expr {int( ($rn*$b + $rp*$pb) / $my)}]

                lappend nrow [format "#%02x%02x%02x" $tr $tg $tb]
            }

            $dest put -to 0 $ny [list $nrow]

            incr ytot $my
            incr ny
         }

         set prevrow $thisrow
         set prow $row

         update idletasks
    }

    # Finish off last rows
    while { $ny < $newy } {
         $dest put -to 0 $ny [list $row]
         incr ny
    }
    update idletasks

    return $dest
}