***元ネタ [#j0102083]
http://wiki.tcl.tk/11232
***これは何をするものか？ [#h67857b7]
GIMPのScript-Fuのリモート操作サーバをTclから操作するためのライブラリです。元ネタのソースが動かなくなっていたので、GIMP2.8日本語環境で動くようにしてパッケージ化したものです。
***使い方 [#nf15562b]
0.下記ダウンロードよりダウンロードしてlibディレクトリにライブラリを配置する。~
1.GIMPを起動する。~
2.Filter→Script-Fu→サーバースタート... からサーバを起動する。ポートはデフォルトの10008で。~
これで準備OK。~
3.tclsh~
4.package require gimp~
5.set gimp [gimp::connect]~
6..以下色々な操作...~
***ソースコード [#f1bb6c0f]
# Tcl client for Gimp's Script-Fu Server.
# Copyright(C) 2004 Salvatore Sanfilippo
#
# This is free software, under the terms of the GPL license version 2.
# You can get a copy of the license from http://www.gnu.org/copyleft/gpl.html
#
# TODO:
#
# - Define more constants
# - Write some decent example
# - Add some higher level subcommand with sane defaults
# and options to specify more details, in the Tcl way.
package provide gimp 1.0
namespace eval gimp {}
namespace eval gimp::method {}
set gimp::debug 1
# GIMP constants
# Image type
set gimp::RGB 0
set gimp::GRAY 1
set gimp::INDEXED 2
# Layer type
set gimp::RGB_IMAGE 0
set gimp::RGBA_IMAGE 1
set gimp::GRAY_IMAGE 2
set gimp::GRAYA_IMAGE 3
set gimp::INDEXED_IMAGE 4
set gimp::INDEXEDA_IMAGE 5
# Layer mode
set gimp::NORMAL_MODE 0
set gimp::DISSOLVE_MODE 1
set gimp::BEHIND_MODE 2
set gimp::MULTIPLY_MODE 3
set gimp::SCREEN_MODE 4
set gimp::OVERLAY_MODE 5
set gimp::DIFFERENCE_MODE 6
set gimp::ADDITION_MODE 7
set gimp::SUBTRACT_MODE 8
set gimp::DARKEN_ONLY_MODE 9
set gimp::LIGHTEN_ONLY_MODE 10
set gimp::HUE_MODE 11
set gimp::SATURATION_MODE 12
set gimp::COLOR_MODE 13
set gimp::VALUE_MODE 14
set gimp::DIVIDE_MODE 15
set gimp::DODGE_MODE 16
set gimp::BURN_MODE 17
set gimp::HARDLIGHT_MODE 18
set gimp::SOFTLIGHT_MODE 19
set gimp::GRAIN_EXTRACT_MODE 20
set gimp::GRAIN_MERGE_MODE 21
set gimp::COLOR_ERASE_MODE 22
# Fill type
set gimp::FOREGROUND_FILL 0
set gimp::BACKGROUND_FILL 1
set gimp::WHITE_FILL 2
set gimp::TRANSPARENT_FILL 3
set gimp::PATTERN_FILL 4
# Units
set gimp::PIXELS 0
set gimp::POINTS 1
# Connect to a running GIMP (with Script-Fu Server enabled)
proc gimp::connect {{host 127.0.0.1} {port 10008}} {
set fd [socket $host $port]
fconfigure $fd -encoding binary -translation binary
set handle "gimp-$fd"
interp alias {} $handle {} gimp::request $fd
set script {
(begin
(define (scheme-list->tcl l)
(let ((len (length l)) (i 0) (res ""))
(set! res (string-append res "{"))
(while (< i len)
(set! res (string-append res (scheme->tcl (nth i l)) " "))
(set! i (+ i 1)))
(set! res (string-append res "}"))
res))
(define (scheme->tcl o)
(cond
((pair? o) (scheme-list->tcl o))
((number? o) (number->string o))
((boolean? o) (if o "1" "0"))
((null? o) "{}")
((string? o) o)))
(define (tclinterface-get-procedure-info procname)
(let ((x (gimp-procedural-db-proc-info procname))
(numargs 0) (numvals 0) (tclargs "") (tclvals "") (i 0))
(begin
(set! numargs (nth 6 x))
(set! numvals (nth 7 x))
(while (< i numargs)
(let ((procinfo (gimp-procedural-db-proc-arg procname i)))
(set! tclargs (string-append tclargs
"{" (number->string (nth 0 procinfo)) " "
"{" (nth 1 procinfo) "}} ")))
(set! i (+ i 1)))
(set! i 0)
(while (< i numvals)
(let ((procinfo (gimp-procedural-db-proc-val procname i)))
(set! tclvals (string-append tclvals
"{" (number->string (nth 0 procinfo)) " "
"{" (nth 1 procinfo) "}} ")))
(set! i (+ i 1)))
(string-append "{" tclargs "} {" tclvals "}")))))
}
set script [string map {\n " "} $script]
::gimp::evalscheme $fd $script
return $handle
}
# Use the Script-Fu Server binary protocol to evaluate a Scheme s-expression.
proc gimp::evalscheme {fd script} {
# Send the query...
set script [string trim $script]
set bin [encoding convertto utf-8 $script]
if {$::gimp::debug} {puts "Script: $script"}
set query "G[binary format S [string length $bin]]$bin"
puts -nonewline $fd $query
flush $fd
# Get the reply...
set hdr [read $fd 4]
binary scan [string index $hdr 1] c errorcode
binary scan [string range $hdr 2 3] S replylen
if {$::gimp::debug} {
puts "Reply error code: $errorcode len: $replylen"
}
set reply [encoding convertfrom utf-8 [read $fd $replylen]]
if {$::gimp::debug} {
puts "Reply: $reply"
}
if {$errorcode} {
error "Script-Fu error '[string trim $reply]' executing '$script'"
}
return $reply
}
# Handle requests to Gimp handlers. Actually it's a dispatcher
# that calls the on-the-fly binding code if needed.
proc gimp::request {fd request args} {
if {[catch {info args ::gimp::method::$request}]} {
::gimp::trytobind $fd $request
}
eval ::gimp::method::$request $fd $args
}
# Try to create bindings on-the-fly for the called Scheme function.
proc gimp::trytobind {fd funcname} {
set pdbname [string map [list - _] $funcname]
set scheme "(tclinterface-get-procedure-info \"$pdbname\")"
if {[catch {::gimp::evalscheme $fd $scheme} result]} {
# No PDB function with this name
return
} else {
foreach {args vals} $result break
set arglist fd
set scheme "(scheme->tcl ($funcname "
foreach a $args {
foreach {type name} $a break
append scheme "\[::gimp::tcl->scheme $type \${$name}\] "
lappend arglist $name
}
append scheme "))"
if {$::gimp::debug} {
puts $scheme
}
if {[llength $vals] > 1} {
proc ::gimp::method::$funcname $arglist [format {
::gimp::evalscheme $fd %s
} "\"$scheme\""]
} else {
proc ::gimp::method::$funcname $arglist [format {
lindex [::gimp::evalscheme $fd %s] 0
} "\"$scheme\""]
}
}
}
# Convert Tcl PDB arguments to Scheme's equivalent
proc gimp::tcl->scheme {type val} {
switch -- $type {
0 - 1 - 2 - 3 {
# Number and IDs
return $val
}
5 - 6 - 7 - 8 - 9 - 10 {
# Array of different types
set res "'("
foreach e $val {
append res [switch $type {
5 - 6 - 7 - 8 - 10 {::gimp::tcl->scheme 0 $e}
9 {::gimp::tcl->scheme 4 $e}
}] " "
}
append res ")"
}
4 {
# String
set q [list $val]
if {[string length $q] != [string length $val]} {
return "\"[string range $q 1 end-1]\""
} else {
return "\"$val\""
}
}
default {
# Id of images, layers, and so on.
return $val
}
}
}
# Methods that does not have a counter-part in the Scheme environment
# Eval a scheme script
proc gimp::method::remote-eval {fd script} {
::gimp::evalscheme $fd $script
}
# Close the link with Gimp and remove the alias
proc gimp::method::close fd {
::close $fd
set handle "gimp-$fd"
interp alias {} $handle {}
}
# Testing
proc gimp::example {} {
set gimp [gimp::connect]
set width 300
set height 150
set bgcolor [list 63 113 187]
set textcolor [list 255 255 0]
set img [$gimp gimp-image-new $width $height $gimp::RGB]
set drawable [$gimp gimp-layer-new $img $width $height
$gimp::RGB_IMAGE "FooLayer" 100 $gimp::NORMAL_MODE]
$gimp gimp-image-undo-disable $img
$gimp gimp-image-add-layer $img $drawable 0
$gimp gimp-palette-set-foreground $textcolor
$gimp gimp-palette-set-background $bgcolor
$gimp gimp-edit-fill $drawable $gimp::BACKGROUND_FILL
$gimp gimp-drawable-update $drawable 0 0 $width $height
$gimp gimp-text-fontname $img $drawable 10 10 "Tcl+Gimp=Fun" 0 1 30
$gimp::PIXELS "Verdana"
$gimp gimp-display-new $img
$gimp gimp-image-undo-enable $img
$gimp close
}
#gimp::example
***サンプルコード [#a125f1c2]
とくにありません。gimp::exampleを実行してみてください。
***ダウンロード [#y17cc2f3]
http://reddog.s35.xrea.com/software/tcl-gimp.zip
***コメントをどーぞ [#xa0840fc]
#comment
----
[[CategoryTclTk]]
HTML convert time: 0.002 sec.