1# rest.tcl -- 2# 3# A framework for RESTful web services 4# 5# Copyright (c) 2009 Aaron Faupell 6# 7# RCS: @(#) $Id: rest.tcl,v 1.7 2009/10/14 16:28:18 afaupell Exp $ 8 9package require Tcl 8.5 10package require http 2.7 11package require json 12package require tdom 13package require base64 14 15package provide rest 1.0 16 17namespace eval ::rest { 18 namespace export create_interface parameters parse_opts save \ 19 describe substitute 20} 21 22# simple -- 23# 24# perform a simple rest call 25# 26# ARGS: 27# url name of the array containing command definitions 28# query query string or list of key/value pairs to be passed to http::formatQuery 29# config (optional) dict containing configuration options for the call 30# body (optional) data for the body of the http request 31# 32# RETURNS: 33# the data from the rest call 34# 35proc ::rest::simple {url query args} { 36 set headers [list] 37 set config [lindex $args 0] 38 if {[string index $config 0] == "-"} { 39 set opts [parse_opts {} {} {headers: cookie: auth: format: method:} [join $args]] 40 set config [lindex $opts 0] 41 set body [lindex $opts 1] 42 } else { 43 set body [lindex $args 1] 44 } 45 46 # make sure we know which method to use 47 if {![dict exists $config method]} { 48 # set the method using the name we were invoked with (through interp alias) 49 dict set config method [namespace tail [lindex [dict get [info frame -1] cmd] 0]] 50 if {[dict get $config method] == "simple"} { dict set config method get } 51 } 52 53 if {[string first " " $query] > 0} { 54 # if query has a space assume it is a list of key value pairs, and do the formatting 55 set query [eval ::http::formatQuery $query] 56 } elseif {[string first ? $url] > 0 && $query == ""} { 57 # if the url contains a query string and query empty then split it to the correct vars 58 set query [join [lrange [split $url ?] 1 end] ?] 59 set url [lindex [split $url ?] 0] 60 } 61 62 if {[dict exists $config auth]} { 63 set auth [dict get $config auth] 64 if {[lindex $auth 0] == "basic"} { 65 lappend headers Authorization "Basic [base64::encode [lindex $auth 1]:[lindex $auth 2]]" 66 } 67 } 68 if {[dict exists $config headers]} { 69 dict for {key val} [dict get $config headers] { lappend headers $key $val } 70 } 71 if {[dict exists $config cookie]} { 72 lappend headers Cookie [join [dict get $config cookie] \;] 73 } 74 75 set result [::rest::_call {} $headers $url $query $body] 76 77 # if a format was specified then convert the data, but dont do any auto formatting 78 if {[dict exists $config result]} { 79 set result [::rest::format_[dict get $config result] $result] 80 } 81 82 return $result 83} 84 85interp alias {} ::rest::get {} ::rest::simple 86interp alias {} ::rest::post {} ::rest::simple 87interp alias {} ::rest::head {} ::rest::simple 88interp alias {} ::rest::put {} ::rest::simple 89interp alias {} ::rest::delete {} ::rest::simple 90 91# create_interface -- 92# 93# use an array which defines a rest API to construct a set of procs 94# 95# ARGS: 96# name name of the array containing command definitions 97# 98# EFFECTS: 99# creates a new namespace and builds api procedures within it 100# 101# RETURNS: 102# the name of the new namespace, which is the same as the input name 103# 104proc ::rest::create_interface {name} { 105 upvar $name in 106 107 # check if any defined calls have https urls and automatically load and register tls 108 #if {[catch {package present tls}]} { 109 # foreach x [array names in] { 110 # if {[dict exists $in($x) url] && [string match https://* [dict get $in($x) url]]} { 111 # package require tls 112 # ::http::register https 443 [list ::tls::socket] 113 # break 114 # } 115 # } 116 #} 117 118 namespace eval ::$name {} 119 foreach call [array names in] { 120 set config $in($call) 121 set proc [list] 122 123 if {[dict exists $config copy]} { 124 set config [dict merge $in([dict get $config copy]) $config] 125 } 126 if {[dict exists $config unset]} { 127 set config [eval [list dict remove $config] [dict get $config unset]] 128 } 129 if {[dict exists $config content-type]} { 130 dict set config headers content-type [dict get $config content-type] 131 } 132 133 lappend proc "set config \{$config\}" 134 lappend proc "set headers \{\}" 135 136 # invocation option processing 137 _addopts [dict get $config url] config 138 if {[dict exists $config headers]} { 139 dict for {k val} [dict get $config headers] { 140 _addopts $val config 141 } 142 } 143 set opts [list] 144 lappend proc "set static \{[expr {[dict exists $config static_args] ? [dict get $config static_args] : {}}]\}" 145 lappend proc {variable static_args} 146 lappend proc {if {[info exists static_args]} { set static [dict merge $static $static_args] }} 147 lappend opts [expr {[dict exists $config req_args] ? [dict get $config req_args] : ""}] 148 lappend opts [expr {[dict exists $config opt_args] ? [dict get $config opt_args] : ""}] 149 lappend proc "set parsed \[::rest::parse_opts \$static $opts \$args]" 150 lappend proc {set query [lindex $parsed 0]} 151 lappend proc {set body [lindex $parsed 1]} 152 lappend proc {set url [::rest::substitute [dict get $config url] query]} 153 if {[dict exists $config body]} { 154 if {[string match req* [dict get $config body]]} { 155 lappend proc {if {$body == ""} { return -code error "wrong # args: should be \"[lindex [info level 0] 0] ?options? string\"" }} 156 } elseif {[string match no* [dict get $config body]]} { 157 lappend proc {if {$body != ""} { return -code error "extra arguments after options" }} 158 } elseif {[string match arg* [lindex [dict get $config body] 0]]} { 159 lappend proc {if {$body == ""} { return -code error "wrong # args: should be \"[lindex [info level 0] 0] ?options? string\"" }} 160 lappend proc "lappend query [lindex [dict get $config body] 1] \$body" {set body ""} 161 } elseif {[string match mime_multi* [lindex [dict get $config body] 0]]} { 162 lappend proc {if {$body == ""} { return -code error "wrong # args: should be \"[lindex [info level 0] 0] ?options? string\"" }} 163 lappend proc {set b [::rest::mime_multipart body $body]} 164 lappend proc {dict set config headers content-type "multipart/related; boundary=$b"} 165 } 166 } 167 # end option processing 168 169 if {[dict exists $config auth]} { 170 set auth [dict get $config auth] 171 if {$auth == "basic"} { 172 lappend proc "lappend headers Authorization \"Basic \[base64::encode \$\{::${name}::user\}:\$\{::${name}::password\}]\"" 173 if {[info commands ::${name}::basic_auth] == ""} { 174 proc ::${name}::basic_auth {u p} { 175 variable user $u 176 variable password $p 177 } 178 } 179 } 180 } 181 182 if {[dict exists $config headers]} { 183 lappend proc {dict for {key val} [dict get $config headers] { lappend headers $key [::rest::substitute $val query] }} 184 } 185 if {[dict exists $config cookie]} { 186 lappend proc {lappend headers Cookie [join [dict get $config cookie] \;]} 187 } 188 _transform $name $call $config proc input_transform query 189 if {[dict exists $config auth] && [lindex [dict get $config auth] 0] == "sign"} { 190 lappend proc "set query \[::${name}::[lindex [dict get $config auth] 1] \$query]" 191 } 192 193 lappend proc {set query [eval ::http::formatQuery $query]} 194 195 # if this is an async call (has defined a callback) 196 # then end the main proc here by returning the http token 197 # the rest of the normal result processing will be put in a _callback_NAME 198 # proc which is called by the generic _callback proc 199 if {[dict exists $config callback]} { 200 lappend proc "set t \[::rest::_call \{[list ::${name}::_callback_$call [dict get $config callback]]\} \$headers \$url \$query \$body]" 201 lappend proc {return $t} 202 proc ::${name}::$call args [join $proc \n] 203 set proc {} 204 lappend proc {upvar token token} 205 } else { 206 lappend proc {set result [::rest::_call {} $headers $url $query $body]} 207 } 208 209 # process results 210 _transform $name $call $config proc pre_transform result 211 if {[dict exists $config result]} { 212 lappend proc "set result \[::rest::format_[dict get $config result] \$result]" 213 } elseif {[dict exists $config format]} { 214 lappend proc "set result \[::rest::format_[dict get $config format] \$result]" 215 } else { 216 lappend proc "set result \[::rest::format_auto \$result]" 217 } 218 _transform $name $call $config proc post_transform result 219 if {[dict exists $config check_result]} { 220 lappend proc "::rest::_check_result \$result [dict get $config check_result]" 221 } 222 # end process results 223 224 # if this is an async call (has a defined callback) 225 # create the callback proc which contains only the result processing and 226 # a handoff to the user defined callback 227 # otherwise create the normal call proc 228 if {[dict exists $config callback]} { 229 lappend proc "[dict get $config callback] $call OK \$result" 230 proc ::${name}::_callback_$call {result} [join $proc \n] 231 } else { 232 lappend proc {return $result} 233 proc ::${name}::$call args [join $proc \n] 234 } 235 } 236 237 proc ::${name}::set_static_args {args} { 238 variable static_args 239 set static_args $args 240 } 241 242 set ::${name}::static_args {} 243 244 # print the contents of all the dynamic generated procs 245 if {0} { 246 foreach x [info commands ::${name}::*] { 247 puts "proc $x \{[info args $x]\} \{\n[info body $x]\n\}\n" 248 } 249 } 250 return $name 251} 252 253# mime_multipart -- 254# 255# creates a mime mulipart message 256# 257# ARGS: 258# var name of variable in which the mime body is stored 259# body a list of key/value pairs which represent mime part 260# headers and bodies. the header is itself a list of 261# value pairs which define header fields 262# 263# EFFECTS: 264# replaces $var with a mime body 265# 266# RETURNS: 267# the mime boundary string 268# 269proc ::rest::mime_multipart {var body} { 270 upvar $var out 271 set out {} 272 set boundary _000-MIME_SEPERATOR 273 foreach {head data} $body { 274 append out \n--$boundary\n 275 foreach {k v} $head { 276 append out "$k: $v\n" 277 } 278 append out \n$data\n 279 } 280 append out \n--$boundary--\n 281 return $boundary 282} 283 284# _transform -- 285# 286# called by create_interface to handle the creation of user defined procedures 287# 288# ARGS: 289# ns target namespace 290# call name of the proc that is being created 291# config dict of config options 292# proc name of variable holding the proc being created 293# name name of the transform 294# 295# EFFECTS: 296# appends commands to the proc variable and possible creates a new proc 297# 298# RETURNS: 299# nothing 300# 301proc ::rest::_transform {ns call config proc name var} { 302 upvar $proc p 303 if {[dict exists $config $name]} { 304 set t [dict get $config $name] 305 if {[llength [split $t]] == 1 && [info commands $t] != ""} { 306 lappend p "set $var \[$t \$$var]" 307 } else { 308 lappend p "set $var \[::${ns}::_${name}_$call \$$var]" 309 proc ::${ns}::_${name}_$call $var $t 310 } 311 } 312} 313 314# save -- 315# 316# saves a copy of the dynamically created procs to a file for later loading 317# 318# ARGS: 319# name name of the array containing command definitions 320# file name of file in which to save the generated commands 321# 322# RETURNS: 323# nothing 324# 325proc ::rest::save {name file} { 326 set fh [open $file w] 327 puts $fh {package require http 328package require json 329package require tdom 330package require base64 331} 332 333 if {![catch {package present tls}]} { 334 puts $fh { 335package require tls 336::http::register https 443 [list ::tls::socket] 337} 338 } 339 340 puts $fh "namespace eval ::$name \{\}\n" 341 foreach x {_call _callback parse_opts _addopts substitute _check_result \ 342 format_auto format_raw format_xml format_json format_discard \ 343 format_tdom} { 344 puts $fh "proc ::${name}::$x \{[info args $x]\} \{[info body $x]\n\}\n" 345 } 346 foreach x [info commands ::${name}::*] { 347 puts $fh "proc $x \{[info args $x]\} \{\n[info body $x]\n\}\n" 348 } 349 close $fh 350} 351 352# parameters -- 353# 354# parse a url query string into a dict 355# 356# ARGS: 357# url a url with a query string seperated by a '?' 358# args optionally a dict key to return instead of the entire dict 359# 360# RETURNS: 361# a dict containing the parsed query string 362# 363proc ::rest::parameters {url args} { 364 set dict [list] 365 foreach x [split [lindex [split $url ?] 1] &] { 366 set x [split $x =] 367 if {[llength $x] < 2} { lappend x "" } 368 eval lappend dict $x 369 } 370 if {[llength $args] > 0} { 371 return [dict get $dict [lindex $args 0]] 372 } 373 return $dict 374} 375 376# _call -- 377# 378# makes an http request 379# expected to be called only by a generated procedure because it depends on the 380# config dict 381# 382# ARGS: 383# name name of the array containing command definitions 384# callback empty string, or a list of 2 callback procs, 385# generated and user defined. if not empty the call will 386# be made async (-command argument to geturl) 387# headers a dict of keys/values for the http request header 388# url the url to request 389# query 390# body 391# 392# EFFECTS: 393# creates a new namespace and builds api procedures within it 394# 395# RETURNS: 396# the data from the http reply, or an http token if the request was async 397# 398proc ::rest::_call {callback headers url query body} { 399 #puts "_call [list $callback $headers $url $query $body]" 400 # get the settings from the calling proc 401 upvar config config 402 403 set method GET 404 if {[dict exists $config method]} { set method [string toupper [dict get $config method]] } 405 406 # assume the query should really be the body for post or put requests 407 # with no other body. doesnt seem technically correct but works for 408 # everything I have encountered. there is no way for the call definition to 409 # specify the difference between url parameters and request body 410 if {[dict exists $config body] && [string match no* [dict get $config body]]} { 411 # never put the query in the body if the user said no body 412 } elseif {($method == "POST" || $method == "PUT") && $query != "" && $body == ""} { 413 set body $query 414 set query {} 415 } 416 if {$query != ""} { append url ?$query } 417 418 # configure options to the geturl command 419 set opts [list] 420 lappend opts -method $method 421 if {[dict exists $headers content-type]} { 422 lappend opts -type [dict get $headers content-type] 423 set headers [dict remove $headers content-type] 424 } 425 if {$body != ""} { 426 lappend opts -query $body 427 } 428 if {$callback != ""} { 429 lappend opts -command [list ::rest::_callback {*}$callback] 430 } 431 432 #puts "headers $headers" 433 #puts "opts $opts" 434 #puts "geturl $url" 435 #return 436 set t [http::geturl $url -headers $headers {*}$opts] 437 438 # if this is an async request return now, otherwise process the result 439 if {$callback != ""} { return $t } 440 if {![string match 2* [http::ncode $t]]} { 441 #parray $t 442 if {[string match {30[12]} [http::ncode $t]]} { 443 upvar #0 $t a 444 return -code error [list HTTP [http::ncode $t] [dict get $a(meta) Location]] 445 } 446 return -code error [list HTTP [http::ncode $t]] 447 } 448 set data [http::data $t] 449 # copy the token into the calling scope so that the transforms can access it 450 # via uplevel, and we can still call cleanup on the real token 451 upvar token token 452 array set token [array get $t] 453 454 #parray $t 455 #puts "data: $data" 456 http::cleanup $t 457 return $data 458} 459 460# _callback -- 461# 462# callback procedure for async http requests 463# 464# ARGS: 465# datacb name of the dynamically generated callback proc created by 466# create_interface which contains post transforms and content 467# interpreting 468# usercb the name of the user supplied callback function. 469# if there is an error it is called directly from here, 470# otherwise the datacb calls it 471# t the http request token 472# 473# EFFECTS: 474# evaluates http error conditions and calls the user defined callback 475# 476# RETURNS: 477# nothing 478# 479proc ::rest::_callback {datacb usercb t} { 480 # copy the token into the local scope so that the datacb can access it 481 # via uplevel, and we can still call cleanup on the real token 482 array set token [array get $t] 483 if {![string match 2* [http::ncode $t]]} { 484 set data [list HTTP [http::ncode $t]] 485 if {[http::ncode $t] == "302"} { 486 lappend data [dict get $token(meta) Location] 487 } 488 http::cleanup $t 489 $usercb ERROR $data 490 return 491 } 492 set data [http::data $t] 493 http::cleanup $t 494 eval $datacb [list $data] 495} 496 497# parse_opts -- 498# 499# command option parsing 500# 501# ARGS: 502# static a dict of options and values that are always present 503# required a list of options that must be supplied 504# optional a list of options that may appear but are not required 505# the format is 506# name - an option which is present or not, no default 507# name: - an option which requires a value 508# name:value - an option with a default value 509# options the string of options supplied by the user at invocation 510# 511# EFFECTS: 512# none 513# 514# RETURNS: 515# a 2 item list. the first item is a dict containing the parsed 516# options and their values. the second item is a string of any 517# remaining data 518# ex: [list [dict create opt1 value1 opt2 value2] {some extra text supplied to the command}] 519# 520proc ::rest::parse_opts {static required optional options} { 521 #puts "static $static\nrequired $required\noptional $optional\noptions $options" 522 set args $options 523 set query {} 524 foreach {k v} $static { 525 set k [string trimleft $k -] 526 lappend query $k $v 527 } 528 529 foreach opt $required { 530 if {[string index $opt end] == ":"} { 531 set opt [string range $opt 0 end-1] 532 } 533 if {[set i [lsearch -exact $args -$opt]] >= 0} { 534 if {[llength $args] <= $i+1} { return -code error "the -$opt argument requires a value" } 535 lappend query $opt [lindex $args [expr {$i+1}]] 536 set args [lreplace $args $i [expr {$i+1}]] 537 } elseif {[set i [lsearch -regexp $static ^-?$opt$]] >= 0} { 538 lappend query $opt [lindex $static [expr {$i+1}]] 539 set static [lreplace $static $i [expr {$i+1}]] 540 } else { 541 return -code error "the -$opt argument is required" 542 } 543 } 544 545 while {[llength $args] > 0} { 546 set opt [lindex $args 0] 547 if {![string match -* $opt]} break 548 if {$opt == "--"} { 549 set args [lreplace $args 0 0] 550 break 551 } 552 set opt [string range $opt 1 end] 553 554 if {[set i [lsearch $optional $opt:*]] > -1} { 555 lappend query $opt [lindex $args 1] 556 set args [lreplace $args 0 1] 557 set optional [lreplace $optional $i $i] 558 } elseif {[set i [lsearch -exact $optional $opt]] > -1} { 559 lappend query $opt "" 560 set args [lreplace $args 0 0] 561 set optional [lreplace $optional $i $i] 562 } else { 563 set opts {} 564 foreach x [concat $required $optional] { lappend opts -[string trimright $x :] } 565 if {[llength $opts] > 0} { 566 return -code error "bad option \"$opt\": Must be [join $opts ", "]" 567 } 568 return -code error "bad option \"$opt\"" 569 } 570 } 571 572 foreach opt $optional { 573 if {[set i [lsearch -regexp $static ^-?$opt$]] >= 0} { 574 lappend query $opt [lindex $static [expr {$i+1}]] 575 set static [lreplace $static $i [expr {$i+1}]] 576 } elseif {[string match *:?* $opt]} { 577 set opt [split $opt :] 578 lappend query [lindex $opt 0] [join [lrange $opt 1 end]] 579 } 580 } 581 #puts "optional $optional\nquery $query" 582 return [list $query [join $args]] 583} 584 585# _addopts -- 586# 587# add inline argument identifiers to the options list 588# 589# ARGS: 590# str a string which may contain %word% option identifiers 591# c name of the config variable 592# 593# EFFECTS: 594# modifies the option variable to add any identifiers found 595# 596# RETURNS: 597# nothing 598# 599proc ::rest::_addopts {str c} { 600 upvar $c config 601 foreach {junk x} [regexp -all -inline -nocase {%([a-z0-9_:-]+)%} $str] { 602 if {[string match *:* $x]} { 603 dict lappend config opt_args $x 604 } else { 605 dict lappend config req_args $x: 606 } 607 } 608} 609 610# substitute -- 611# 612# take a string and substitute real values for any option identifiers 613# 614# ARGS: 615# input a string which may contain %word% option identifiers 616# q name of a variable containing a dict of options and values 617# 618# EFFECTS: 619# removes any substituted options from the q variable 620# 621# RETURNS: 622# the input string with option identifiers replaced by real values 623# 624proc ::rest::substitute {input q} { 625 upvar $q query 626 foreach {junk name} [regexp -all -inline -nocase {%([a-z0-9_:-]+)%} $input] { 627 set opt [lindex [split $name :] 0] 628 if {[dict exists $query $opt]} { 629 set replace [dict get $query $opt] 630 #set replace [string map {/ %2F} $replace] 631 #set replace [string range [http::formatQuery "" $replace] 1 end] 632 set query [dict remove $query $opt] 633 } else { 634 set replace {} 635 } 636 set input [string map [list %$name% $replace] $input] 637 } 638 return $input 639} 640 641# describe -- 642# 643# print a description of defined api calls 644# 645# ARGS: 646# name name of an interface previously created with create_interface 647# 648# RETURNS: 649# nothing 650# 651proc ::rest::describe {name} { 652 # replace [set], then run all the procs to get the value of the config var 653 rename ::set ::_set 654 proc ::set {var val} { 655 if {[lindex [info level 0] 1] != "config"} { continue } 656 upvar 2 config c 657 ::_set c([info level -1]) $val 658 return -code return 659 } 660 foreach call [lsort -dictionary [info commands ::${name}::*]] { 661 if {[string match *::_* $call]} { continue } 662 catch {$call} 663 } 664 rename ::set {} 665 rename ::_set ::set 666 667 foreach {name val} [array get config] { 668 puts -nonewline "$name" 669 if {([dict exists $val req_args] && [dict get $val req_args] != "") \ 670 || ([dict exists $val opt_args] && [dict get $val opt_args] != "")} { 671 puts -nonewline " <options>" 672 } 673 if {[dict exists $val body] && [dict get $val body] == "required"} { 674 puts -nonewline " <body>" 675 } 676 puts "" 677 if {[dict exists $val description]} { 678 puts "[regsub -all {[\s\n]+} [dict get $val description] { }]" 679 } 680 if {[dict exists $val callback]} { 681 puts "Async callback: [dict get $val callback]" 682 } 683 puts " Required arguments:" 684 if {[dict exists $val req_args]} { 685 foreach x [dict get $val req_args] { 686 puts " -[format %-12s [string trimright $x :]] <value>" 687 } 688 } else { 689 puts " none" 690 } 691 puts " Optional arguments:" 692 if {[dict exists $val opt_args]} { 693 foreach x [dict get $val opt_args] { 694 if {![string match *:* $x]} { 695 puts " $x" 696 } else { 697 set x [split $x :] 698 if {[lindex $x 1] == ""} { 699 puts " -[format %-12s [lindex $x 0]] <value>" 700 } else { 701 puts " -[format %-12s [lindex $x 0]] <value> default \"[lindex $x 1]\"" 702 } 703 } 704 } 705 } else { 706 puts " none" 707 } 708 puts "" 709 } 710} 711 712# _check_result -- 713# 714# checks http returned data against user supplied conditions 715# 716# ARGS: 717# result name of the array containing command definitions 718# ok an expression which if it returns false causes an error 719# err an expression which if it returns true causes an error 720# 721# EFFECTS: 722# throws an error if the expression evaluations indicate an error 723# 724# RETURNS: 725# nothing 726# 727proc ::rest::_check_result {result ok err} { 728 if {$err != "" && ![catch {expr $err} out] && [expr {$out}]} { 729 return -code error [list ERR $result "triggered error condition" $err $out] 730 } 731 if {$ok == "" || (![catch {expr $ok} out] && [expr {$out}])} { 732 return -code ok 733 } 734 return -code error [list ERR $result "ok expression failed or returned false" $ok $out] 735} 736 737# format_auto -- 738# 739# the default data formatter. tries to detect the data type and dispatch 740# to a specific handler 741# 742# ARGS: 743# data data returned by an http call 744# 745# RETURNS: 746# data, possibly transformed in a representation specific manner 747# 748proc ::rest::format_auto {data} { 749 if {[string match {<*} [string trimleft $data]]} { 750 return [format_xml $data] 751 } 752 if {[string match \{* $data] || [regexp {":\s*[\{\[]} $data]} { 753 return [format_json $data] 754 } 755 return $data 756} 757 758proc ::rest::format_raw {data} { 759 return $data 760} 761 762proc ::rest::format_discard {data} { 763 return -code ok 764} 765 766proc ::rest::format_json {data} { 767 #if {[regexp -nocase {^[a-z_.]+ *= *(.*)} $data -> json]} { 768 # set data $json 769 #} 770 return [json::json2dict $data] 771} 772 773proc ::rest::format_xml {data} { 774 set d [[dom parse $data] documentElement] 775 set data [$d asList] 776 if {[lindex $data 0] == "rss"} { 777 set data [format_rss $data] 778 } 779 return $data 780} 781 782proc ::rest::format_rss {data} { 783 set data [lindex $data 2 0 2] 784 set out {} 785 set channel {} 786 foreach x $data { 787 if {[lindex $x 0] != "item"} { 788 lappend channel [lindex $x 0] \ 789 [linsert [lindex $x 1] end content [lindex $x 2 0 1]] 790 } else { 791 set tmp {} 792 foreach item [lindex $x 2] { 793 lappend tmp [lindex $item 0] \ 794 [linsert [lindex $item 1] end content [lindex $item 2 0 1]] 795 } 796 lappend out item $tmp 797 } 798 } 799 return [linsert $out 0 channel $channel] 800} 801 802proc ::rest::format_tdom {data} { 803 return [[dom parse $data] documentElement] 804} 805