[Tkabber-dev] r1613 - in trunk/tkabber-plugins: . whiteboard

tkabber-svn at jabber.ru tkabber-svn at jabber.ru
Sat Nov 15 00:07:36 MSK 2008


Author: sergei
Date: 2008-11-15 00:07:35 +0300 (Sat, 15 Nov 2008)
New Revision: 1613

Modified:
   trunk/tkabber-plugins/ChangeLog
   trunk/tkabber-plugins/whiteboard/svgrender.tcl
   trunk/tkabber-plugins/whiteboard/whiteboard.tcl
Log:
	* whiteboard/svgrender.tcl, whiteboard/whiteboard.tcl: Added
	  preliminary bitmap support (though it doesn't conform SVG
	  specifications, so it's currently intended to polish interface part
	  and subsequently rewrite XML part).


Modified: trunk/tkabber-plugins/ChangeLog
===================================================================
--- trunk/tkabber-plugins/ChangeLog	2008-11-11 10:48:08 UTC (rev 1612)
+++ trunk/tkabber-plugins/ChangeLog	2008-11-14 21:07:35 UTC (rev 1613)
@@ -1,3 +1,10 @@
+2008-11-15  Sergei Golovan <sgolovan at nes.ru>
+
+	* whiteboard/svgrender.tcl, whiteboard/whiteboard.tcl: Added
+	  preliminary bitmap support (though it doesn't conform SVG
+	  specifications, so it's currently intended to polish interface part
+	  and subsequently rewrite XML part).
+
 2008-11-09  Sergei Golovan <sgolovan at nes.ru>
 
 	* traffic/traffic.tcl: Adapted traffic plugin to new log callback from

Modified: trunk/tkabber-plugins/whiteboard/svgrender.tcl
===================================================================
--- trunk/tkabber-plugins/whiteboard/svgrender.tcl	2008-11-11 10:48:08 UTC (rev 1612)
+++ trunk/tkabber-plugins/whiteboard/svgrender.tcl	2008-11-14 21:07:35 UTC (rev 1613)
@@ -8,6 +8,8 @@
 	variable Smooth 0
     }
 
+    catch {package require Img}
+
     variable Debug 0
 }
 
@@ -58,6 +60,9 @@
 	text {
 	    ParseText $c $transform $curAttrs $item
 	}
+	image {
+	    ParseImage $c $transform $curAttrs $item
+	}
 	g {
 	    ParseG $c $transform $curAttrs $attrs $subels
 	}
@@ -385,6 +390,35 @@
     eval [list $c create line] $p $opts
 }
 
+proc svg::ParseImage {c transform curAttrs item} {
+    ::xmpp::xml::split $item tag xmlns attrs cdata subels
+
+    eval lappend transform \
+	 [ParseTransform [::xmpp::xml::getAttr $attrs transform]]
+
+    set x  [::xmpp::xml::getAttr $attrs x]
+    set y  [::xmpp::xml::getAttr $attrs y]
+
+    if {$x == ""} {set x 0}
+    if {$y == ""} {set y 0}
+
+    foreach {x y} [TransformCoord $transform $x $y] break
+
+    array set Attrs $curAttrs
+    array set Attrs $attrs
+
+    if {[catch {image create photo -data $cdata} image]} {
+	return ""
+    }
+
+    bind $c <Destroy> +[list image delete $image]
+
+    set opts [ImageOpts]
+
+    Debug 2 image $x $y -image $image $opts
+    eval [list $c create image $x $y -image $image] $opts
+}
+
 proc svg::ParseText {c transform curAttrs item} {
     ::xmpp::xml::split $item tag xmlns attrs cdata subels
 
@@ -513,6 +547,18 @@
     return $opts
 }
 
+proc svg::ImageOpts {} {
+    upvar Attrs Attrs
+    upvar c c
+    set opts {-anchor nw}
+    foreach {attr val} [array get Attrs] {
+	switch -- $attr {
+	    id {lappend opts -tags [list [list id $val]]}
+	}
+    }
+    return $opts
+}
+
 proc svg::TextOpts {} {
     upvar Attrs Attrs
     upvar c c

Modified: trunk/tkabber-plugins/whiteboard/whiteboard.tcl
===================================================================
--- trunk/tkabber-plugins/whiteboard/whiteboard.tcl	2008-11-11 10:48:08 UTC (rev 1612)
+++ trunk/tkabber-plugins/whiteboard/whiteboard.tcl	2008-11-14 21:07:35 UTC (rev 1613)
@@ -3,6 +3,8 @@
 uplevel #0 [list source [file join [file dirname [info script]] svgrender.tcl]]
 
 package require msgcat
+package require base64
+catch {package require Img}
 
 ::msgcat::mcload [file join [file dirname [info script]] msgs]
 
@@ -96,6 +98,13 @@
 			-command [list [namespace current]::circle_bind \
 				      $c $chatid]]
 
+    set tbimage [radiobutton $w.tb.image -text [::msgcat::mc "Image"] \
+			-variable [namespace current]::tool($chatid) \
+			-value image \
+			-anchor w \
+			-command [list [namespace current]::image_bind \
+				      $c $chatid]]
+
     set tbtext [radiobutton $w.tb.text -text [::msgcat::mc "Text"] \
 			-variable [namespace current]::tool($chatid) \
 			-value text \
@@ -110,8 +119,8 @@
 			-command [list [namespace current]::move_bind \
 				       $c $chatid]]
 
-    pack $tbfreehand $tbpolyline $tbrectangle $tbpolygon $tbcircle $tbtext \
-	 $tbmove -anchor w -fill x
+    pack $tbfreehand $tbpolyline $tbrectangle $tbpolygon $tbcircle $tbimage \
+	 $tbtext $tbmove -anchor w -fill x
 
     button $w.tb.clear -text [::msgcat::mc "Clear"] \
 	-command [list [namespace current]::send_clear $chatid]
@@ -637,12 +646,12 @@
 proc wb::line_tag {id} {
     variable line
 
-    set arrts $line(options)
-    lappend arrts points $line(coords)
+    set attrs $line(options)
+    lappend attrs points $line(coords)
     if {$id != ""} {
-	lappend arrts id $id
+	lappend attrs id $id
     }
-    return [::xmpp::xml::create polyline -attrs $arrts]
+    return [::xmpp::xml::create polyline -attrs $attrs]
 }
 
 ###############################################################################
@@ -753,12 +762,12 @@
 proc wb::polygon_tag {id} {
     variable polygon
 
-    set arrts $polygon(options)
-    lappend arrts points $polygon(coords)
+    set attrs $polygon(options)
+    lappend attrs points $polygon(coords)
     if {$id != ""} {
-	lappend arrts id $id
+	lappend attrs id $id
     }
-    return [::xmpp::xml::create polygon -attrs $arrts]
+    return [::xmpp::xml::create polygon -attrs $attrs]
 }
 
 ###############################################################################
@@ -846,25 +855,25 @@
 proc wb::rectangle_tag {id} {
     variable rectangle
 
-    set arrts $rectangle(options)
+    set attrs $rectangle(options)
     if {$rectangle(x2) > $rectangle(x1)} {
-	lappend arrts x $rectangle(x1) \
+	lappend attrs x $rectangle(x1) \
 		     width [expr {$rectangle(x2) - $rectangle(x1)}]
     } else {
-	lappend arrts x $rectangle(x2) \
+	lappend attrs x $rectangle(x2) \
 		     width [expr {$rectangle(x1) - $rectangle(x2)}]
     }
     if {$rectangle(y2) > $rectangle(y1)} {
-	lappend arrts y $rectangle(y1) \
+	lappend attrs y $rectangle(y1) \
 		     height [expr {$rectangle(y2) - $rectangle(y1)}]
     } else {
-	lappend arrts y $rectangle(y2) \
+	lappend attrs y $rectangle(y2) \
 		     height [expr {$rectangle(y1) - $rectangle(y2)}]
     }
     if {$id != ""} {
-	lappend arrts id $id
+	lappend attrs id $id
     }
-    return [::xmpp::xml::create rect -attrs $arrts]
+    return [::xmpp::xml::create rect -attrs $attrs]
 }
 
 ###############################################################################
@@ -956,12 +965,12 @@
 proc wb::circle_tag {id r} {
     variable circle
 
-    set arrts $circle(options)
-    lappend arrts r $r
+    set attrs $circle(options)
+    lappend attrs r $r
     if {$id != ""} {
-	lappend arrts id $id
+	lappend attrs id $id
     }
-    return [::xmpp::xml::create circle -attrs $arrts]
+    return [::xmpp::xml::create circle -attrs $attrs]
 }
 
 ###############################################################################
@@ -1042,12 +1051,12 @@
 proc wb::freehand_tag {id} {
     variable line
 
-    set arrts $line(options)
-    lappend arrts points $line(coords)
+    set attrs $line(options)
+    lappend attrs points $line(coords)
     if {$id != ""} {
-	lappend arrts id $id
+	lappend attrs id $id
     }
-    return [::xmpp::xml::create polyline -attrs $arrts]
+    return [::xmpp::xml::create polyline -attrs $attrs]
 }
 
 ###############################################################################
@@ -1161,7 +1170,7 @@
 	    $c addtag [time_tag moved $jid] withtag [list id $id]
 	}
 
-	set arrts [list id $id dx $dx dy $dy]
+	set attrs [list id $id dx $dx dy $dy]
 
 	set xlib [chat::get_xlib $chatid]
 	set jid [chat::get_jid $chatid]
@@ -1170,12 +1179,86 @@
 	    -xlist [list [::xmpp::xml::create x \
 			      -xmlns tkabber:whiteboard \
 			      -subelement [::xmpp::xml::create move \
-						  -attrs $arrts]]]
+						  -attrs $attrs]]]
 	$c configure -cursor ""
     }
 }
 
 ###############################################################################
+# Image
+
+proc wb::image_bind {c chatid} {
+    bind $c <ButtonPress-1> {}
+    bind $c <B1-Motion> {}
+    bind $c <ButtonRelease-1> \
+	    [list [namespace current]::image_b1 [double% $c] [double% $chatid] %x %y]
+    bind $c <Button-3> {}
+    $c configure -cursor crosshair
+}
+
+proc wb::image_b1 {c chatid x y} {
+    variable image_info
+    set image_info(x) [$c canvasx $x]
+    set image_info(y) [$c canvasy $y]
+    set w [win_id whiteboard $chatid]
+    if {[catch { package require Img }]} {
+	set types [list [list [::msgcat::mc "GIF images"] {.gif}] \
+			[list [::msgcat::mc "All files"] {*}]]
+    } else {
+	set types [list [list [::msgcat::mc "All images"] {.jpg .jpeg .gif .png}] \
+			[list [::msgcat::mc "JPEG images"] {.jpg .jpeg}] \
+			[list [::msgcat::mc "GIF images"] {.gif}] \
+			[list [::msgcat::mc "PNG images"] {.png}] \
+			[list [::msgcat::mc "All files"] {*}]]
+    }
+
+    set filename [tk_getOpenFile -filetypes $types]
+    if {$filename == ""} return
+
+    if {[catch {image create photo -file $filename} res]} {
+	if {[winfo exists .load_image_error]} {
+	    destroy .load_image_error
+	}
+	NonmodalMessageDlg .load_image_error -aspect 50000 -icon error \
+			   -message [::msgcat::mc "Loading image failed: %s." \
+						  $res]
+	return
+    }
+
+    image delete $res
+
+    set f [open $filename]
+    fconfigure $f -translation binary
+    set binval [read $f]
+    close $f
+
+    binary scan $binval H4 binsig
+    switch -- $binsig {
+	ffd8 { set type "image/jpeg" }
+	4749 { set type "image/gif" }
+	8950 { set type "image/png" }
+	default { set type "image" }
+    }
+
+    set base64val [base64::encode $binval]
+    
+    set id [create_id]
+    set attrs [list id $id x $image_info(x) y $image_info(y) \
+		    type $type]
+
+    set tag [::xmpp::xml::create image -attrs $attrs -cdata $base64val]
+
+    if {![chat::is_groupchat $chatid]} {
+	set imageid [svg::parseSVGItem $c {} {} $tag]
+	set jid [connection_jid [chat::get_xlib $chatid]]
+	$c addtag [list tag $tag] withtag $imageid
+	$c addtag [time_tag created $jid] withtag $imageid
+    }
+
+    send_svg $chatid $tag
+}
+
+###############################################################################
 # Text
 
 proc wb::text_bind {c chatid} {
@@ -1222,12 +1305,12 @@
 
     set text [set [namespace current]::text_entered($chatid)]
 
-    set arrts [list id $id x $text_info(x) y $text_info(y) \
+    set attrs [list id $id x $text_info(x) y $text_info(y) \
 		   fill [get_text_color $chatid]]
     set font [get_text_font $chatid]
     if {[info exists app_font($font)]} {
 	array set font_opt [font configure $font]
-	lappend arrts font-size $font_opt(-size) \
+	lappend attrs font-size $font_opt(-size) \
 		     font-family $font_opt(-family)
 	if {$font_opt(-underline) || $font_opt(-overstrike)} {
 	    set dec {}
@@ -1237,18 +1320,18 @@
 	    if {$font_opt(-overstrike)} {
 		lappend dec line-through
 	    }
-	    lappend arrts text-decoration $dec
+	    lappend attrs text-decoration $dec
 	}
 	if {[string equal $font_opt(-slant) italic]} {
-	    lappend arrts font-style italic
+	    lappend attrs font-style italic
 	}
 	if {[string equal $font_opt(-weight) bold]} {
-	    lappend arrts font-weight bold
+	    lappend attrs font-weight bold
 	}
 	unset font_opt
     }
 
-    set tag [::xmpp::xml::create text -attrs $arrts -cdata $text]
+    set tag [::xmpp::xml::create text -attrs $attrs -cdata $text]
 
     if {![chat::is_groupchat $chatid]} {
 	set textid [svg::parseSVGItem $c {} {} $tag]



More information about the Tkabber-dev mailing list