├── .gitignore ├── config.tcl.sample ├── README.md ├── Makefile ├── LICENSE ├── tools ├── what-are-people-doing.tcl ├── multi-open.tcl └── fogbugz-git-hook ├── test-harness.tcl └── main.tcl /.gitignore: -------------------------------------------------------------------------------- 1 | config.tcl 2 | -------------------------------------------------------------------------------- /config.tcl.sample: -------------------------------------------------------------------------------- 1 | namespace eval ::fogbugz { 2 | 3 | set ::fogbugz::config(api_url) "https://fogbugz.example.com/api.asp" 4 | set ::fogbugz::config(email) "email@example.com" 5 | set ::fogbugz::config(password) "password1234" 6 | 7 | } 8 | 9 | package provides fogbugz 1.0 10 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Tcl FogBugz XML API Package 2 | =========================== 3 | 4 | This package provides a Tcl native interface to the FogBugz XMP API as 5 | documented at http://fogbugz.stackexchange.com/fogbugz-xml-api 6 | 7 | Requirements 8 | ------------ 9 | 10 | * A [FogBugz](http://www.fogcreek.com/fogbugz/) server or FogBugz On Demand account 11 | * Tcl 8.5 or newer 12 | * [tDOM](https://github.com/tDOM/tdom) 13 | 14 | Other Stuff that's Included 15 | --------------------------- 16 | 17 | * fogbugz-git-hook is a script which can be used to auto-populate a BUGZID 18 | reference in git commits based on the user's "Currently Working On" setting 19 | on the FogBugz server. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # 2 | # Tcl FogBugz API 3 | # 4 | 5 | PACKAGE= fogbugz 6 | FILES= main.tcl 7 | 8 | PREFIX?= /usr/local 9 | LIB?= $(PREFIX)/lib 10 | BIN?= $(PREFIX)/bin 11 | 12 | TARGET?= $(LIB)/$(PACKAGE) 13 | 14 | UID?= 0 15 | GID?= 0 16 | 17 | TCLSH?= tclsh 18 | 19 | all: 20 | 21 | install: install-package install-git-hook 22 | 23 | uninstall: uninstall-package 24 | 25 | install-package: 26 | @echo Installing $(PACKAGE) to $(TARGET) 27 | @install -o $(UID) -g $(GID) -m 0755 -d $(TARGET) 28 | @echo " Copying $(FILES)" 29 | @install -o $(UID) -g $(GID) -m 0644 $(FILES) $(TARGET) 30 | @sed -i '' -e's/tclsh.\../$(TCLSH)/' $(TARGET)/* 31 | @if test -f config.tcl; then install -o $(UID) -g $(GID) -m 0644 config.tcl $(TARGET); echo " Copying config.tcl"; fi 32 | @echo " Generating pkgIndex.tcl" 33 | @cd $(TARGET) && echo "pkg_mkIndex -- ." | $(TCLSH) 34 | @echo "Installation complete" 35 | 36 | make uninstall-package: 37 | rm -rf $(TARGET) 38 | 39 | install-git-hook: 40 | @echo "Installing fogbugz-git-hook to $(BIN)" 41 | @install -o $(UID) -g $(GID) -m 0755 tools/fogbugz-git-hook $(BIN)/ 42 | @sed -i '' -e's/tclsh.\../$(TCLSH)/' $(BIN)/fogbugz-git-hook 43 | 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011, FlightAware LLC 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above 11 | copyright notice, this list of conditions and the following 12 | disclaimer in the documentation and/or other materials provided 13 | with the distribution. 14 | 15 | * Neither the name of the FlightAware LLC nor the names of its 16 | contributors may be used to endorse or promote products derived 17 | from this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /tools/what-are-people-doing.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh8.6 2 | # 3 | # Reference code for the FogBugz API Tcl package 4 | # 5 | # Lists all active users and the state of their "Working on" bug (interval) 6 | # 7 | 8 | package require fogbugz 9 | 10 | proc main {} { 11 | lassign [::fogbugz::login] logged_in token 12 | if {!$logged_in} { 13 | puts "Unable to log in: $token" 14 | exit -1 15 | } 16 | 17 | # 18 | # We only want to look back a couple days, not at every interval since the beginning of time 19 | # 20 | set dtStart [clock format [expr [clock seconds] - (86400 * 2)] -format "%Y-%m-%dT00:00:00Z"] 21 | 22 | # 23 | # Iterate through each user using the listPeople method 24 | # 25 | foreach person [::fogbugz::getList People [dict create token $token]] { 26 | set ixPerson [dict get $person ixPerson] 27 | set sFullName [dict get $person sFullName] 28 | 29 | unset -nocomplain ixBug sTitle 30 | 31 | # 32 | # Iterate through each of this user's recent intervals looking for an open-ended one 33 | # 34 | foreach interval [::fogbugz::getList Intervals [dict create token $token ixPerson $ixPerson dtStart $dtStart]] { 35 | # puts $interval 36 | 37 | if {![dict exists $interval dtEnd]} { 38 | # 39 | # No dtEnd means the interval is in progress. 40 | # 41 | set ixBug [dict get $interval ixBug] 42 | set sTitle [dict get $interval sTitle] 43 | set since [dict get $interval dtStart_epoch] 44 | } 45 | } 46 | 47 | if {[info exists ixBug]} { 48 | set hours [format "%4.2f" [expr ([clock seconds].00 - $since.00) / 60.00 / 60.00]] 49 | set working_on "$sTitle ($ixBug) for $hours hours" 50 | } else { 51 | set working_on "?" 52 | } 53 | puts "[format "%-20s" $sFullName]: $working_on" 54 | } 55 | 56 | ::fogbugz::logoff $token 57 | } 58 | 59 | if !$tcl_interactive main 60 | -------------------------------------------------------------------------------- /test-harness.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh8.6 2 | 3 | # 4 | # Normally you'd just do a 'package require fogbugz' like a normal person. 5 | # 6 | # But we want the test-harness to be able to work from the current directory 7 | # repo checkout to simplify testing. 8 | # 9 | # Source the stuff by hand below: 10 | # 11 | source main.tcl 12 | if {[catch {source config.tcl} err]} { 13 | puts "No configuration found: $err" 14 | exit -1 15 | } 16 | 17 | 18 | proc rule {} { 19 | puts "-- " 20 | } 21 | 22 | proc main {} { 23 | set verbose 0 24 | 25 | parray ::fogbugz::config 26 | lassign [::fogbugz::login] logged_in token 27 | if {!$logged_in} { 28 | puts "Unable to log in: $token" 29 | exit -1 30 | } 31 | puts "Logged in with token $token" 32 | 33 | rule 34 | 35 | if {1} { 36 | # 37 | # Example of using the getList proc for obtaining a list of objects 38 | # from the FogBugz server. 39 | # 40 | foreach listType [array names ::fogbugz::listResult] { 41 | set result [::fogbugz::getList $listType [dict create token $token]] 42 | puts "list$listType returned [llength $result] items" 43 | if {$verbose} { 44 | foreach item $result { 45 | puts "- $item" 46 | } 47 | } 48 | } 49 | rule 50 | } 51 | 52 | if {1} { 53 | # 54 | # Examples of using raw_cmd proc for running a raw API method and returning 55 | # the result data into an array/dict suitable string 56 | # 57 | puts "ixPerson 2:" 58 | array set person [::fogbugz::view Person [dict create token $token ixPerson 2]] 59 | parray person 60 | 61 | rule 62 | 63 | puts "ixStatus 2:" 64 | array set status [::fogbugz::view Status [dict create token $token ixStatus 2]] 65 | parray status 66 | rule 67 | } 68 | 69 | if {1} { 70 | set cols [join {ixBug sTitle sTags sProject sArea sPriority sPersonAssignedTo dtDue} ","] 71 | ::fogbugz::raw_cmd setCurrentFilter [dict create token $token sFilter 48] 72 | foreach casebuf [::fogbugz::search [dict create token $token cols $cols]] { 73 | array set case $casebuf 74 | parray case 75 | rule 76 | } 77 | } 78 | 79 | # 80 | # Logging off. It's not just a good idea, it's the spec. 81 | # 82 | ::fogbugz::logoff $token 83 | } 84 | 85 | if !$tcl_interactive main 86 | -------------------------------------------------------------------------------- /tools/multi-open.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh8.6 2 | # 3 | # Reference code for the FogBugz API Tcl package 4 | # 5 | # Example of using FogBugz API to create a meta/sub bug for 6 | # tracking the same issue/feature on all mobile platforms 7 | # 8 | 9 | package require fogbugz 10 | 11 | proc main {argv} { 12 | lassign [::fogbugz::login] logged_in token 13 | if {!$logged_in} { 14 | puts "Unable to log in: $token" 15 | exit -1 16 | } 17 | 18 | #foreach c [::fogbugz::getList People [dict create token $token]] { 19 | # puts $c 20 | #} 21 | #exit 22 | 23 | # 24 | # These static IDs were just pulled by hand out of our FogBugz server 25 | # 26 | 27 | # Areas 28 | set areas {91 92 37 94} 29 | 30 | # set ixPerson to current user 31 | lassign [::fogbugz::whoami [dict create token $token]] ixPerson sFullName 32 | puts "You are $sFullName ($ixPerson)" 33 | 34 | # 35 | # ixPerson* : 2=nugget 3=dbaker 36 | # ixCategory: 1=Bug 2=Feature 3=Inquiry 4=Schedule Item 5=Code Review 37 | # ixPriority: 1-7 (On Fire .. Placard InOp) 38 | # 39 | array set master { 40 | ixProject 11 41 | ixArea 98 42 | ixCategory 1 43 | ixPriority 3 44 | sTitle "Test Case" 45 | sEvent "This is a test bug, please ignore it" 46 | } 47 | 48 | set master(ixPersonEditedBy) $ixPerson 49 | 50 | parray master 51 | 52 | puts "Creating master case" 53 | 54 | lassign [::fogbugz::raw_cmd new [array get master]] success xml error 55 | 56 | if {!$success} { 57 | puts "Unable to create master bug: $error" 58 | exit -1 59 | } 60 | 61 | puts $xml 62 | 63 | if {[regexp {ixBug="(\d+)"} $xml _ ixBug]} { 64 | puts "Created BUGZID $ixBug: ($master(sTitle))" 65 | 66 | foreach a $areas { 67 | unset -nocomplain subcase 68 | set subcase(ixProject) 11 69 | set subcase(ixArea) $a 70 | set subcase(ixBugParent) $ixBug 71 | set subcase(ixPriority) $master(ixPriority) 72 | set subcase(sTitle) $master(sTitle) 73 | set subcase(sEvent) "This is a platform-specific subcase\n-- \n$master(sEvent)" 74 | set subcase(ixPersonEditedBy) $ixPerson 75 | 76 | lassign [::fogbugz::raw_cmd new [array get subcase]] success xml error 77 | puts " -- Created subase for area $a" 78 | } 79 | } 80 | 81 | ::fogbugz::logoff $token 82 | } 83 | 84 | if !$tcl_interactive { 85 | main $argv 86 | } 87 | -------------------------------------------------------------------------------- /tools/fogbugz-git-hook: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh8.6 2 | 3 | package require fogbugz 4 | 5 | # 6 | # You can hard-code the credentials into this script, and if they exist they'll 7 | # be used. If you don't set these values, the script will simply attempt to use 8 | # any credentials that are embedded in the fogbugz Tcl package if applicable. 9 | # 10 | #set ::api_url "https://fogbugz.example.com/api.asp" 11 | #set ::email "username@example.com" 12 | #set ::password "password1234" 13 | 14 | proc emit_msg {message {comments 0} {bugzid ""}} { 15 | set fp [open $::msgfile w] 16 | if {$comments} { 17 | puts $fp "" 18 | puts $fp "BUGZID:$bugzid" 19 | puts $fp "# ^^" 20 | foreach line [split $message "\n"] { 21 | puts $fp "# $line" 22 | } 23 | puts $fp "# " 24 | foreach line [split $::commit_msg "\n"] { 25 | if {[string trim $line] != ""} { 26 | puts $fp $line 27 | } 28 | } 29 | } else { 30 | puts -nonewline $fp $::commit_msg 31 | puts $fp "BUGZID:$bugzid" 32 | } 33 | close $fp 34 | exit 35 | } 36 | 37 | proc load_msg {filename} { 38 | set fp [open $filename r] 39 | set commit_msg [read $fp] 40 | close $fp 41 | 42 | return $commit_msg 43 | } 44 | 45 | proc bail {{retcode 0} {msg ""}} { 46 | if {[info exists ::token]} { 47 | ::fogbugz::logoff $::token 48 | } 49 | if {$msg != ""} { 50 | if {$retcode} { 51 | puts stderr $msg 52 | } else { 53 | puts $msg 54 | } 55 | } 56 | exit $retcode 57 | } 58 | 59 | proc is_enabled {} { 60 | set enabled "false" 61 | catch {set enabled [exec git config fogbugz.enabled]} 62 | 63 | return [string is true -strict $enabled] 64 | } 65 | 66 | 67 | proc main {argv} { 68 | set emulation [file tail [info script]] 69 | 70 | switch $emulation { 71 | fogbugz-git-hook { 72 | set cmd [lindex $argv 0] 73 | switch $cmd { 74 | init { 75 | set binary [lindex $argv 1] 76 | if {$binary == ""} { 77 | set binary "/usr/local/bin/fogbugz-git-hook" 78 | } 79 | if {![file exists $binary] && ![file executable $binary]} { 80 | bail -1 "Invalid hook script: $binary" 81 | } 82 | 83 | if {[catch { set gitdir [exec git rev-parse --git-dir] } catchResult]} { 84 | bail -1 "Not a git repository: $catchResult" 85 | } 86 | puts "Linking prepare-commit-msg hook" 87 | exec ln -sf $binary $gitdir/hooks/prepare-commit-msg 88 | puts "Linking commit-msg hook" 89 | exec ln -sf $binary $gitdir/hooks/commit-msg 90 | 91 | exec git config fogbugz.enabled true 92 | } 93 | default { 94 | bail -1 "Unrecognized command $argv (Did you mean \"$emulation init\" ?)" 95 | } 96 | } 97 | bail 98 | } 99 | 100 | prepare-commit-msg { 101 | if {![is_enabled]} { 102 | exit 103 | } 104 | 105 | lassign $argv ::msgfile ::msgsource 106 | 107 | if {$::msgsource != ""} { 108 | set comments 0 109 | } else { 110 | set comments 1 111 | } 112 | 113 | if {[file exists $::msgfile]} { 114 | set ::commit_msg [load_msg $::msgfile] 115 | } else { 116 | set ::commit_msg "# No Git-supplied commit message found\n# File doesn't exist: $argv\n#" 117 | } 118 | 119 | if {[info exists ::api_url]} { 120 | lassign [::fogbugz::login $::api_url $::email $::password] logged_in ::token 121 | } else { 122 | lassign [::fogbugz::login] logged_in ::token 123 | } 124 | 125 | if {!$logged_in} { 126 | emit_msg "Unable to connect to FogBugz, sorry ($::token)" $comments 127 | } 128 | 129 | lassign [::fogbugz::whoami [dict create token $::token]] ixPerson sFullName 130 | 131 | if {!$ixPerson} { 132 | emit_msg "Git could not determine your FogBugz User ID so no BUGZID was set" $comments 133 | } 134 | 135 | # debug "You are user id $ixPerson" 136 | 137 | set dtStart [clock format [expr [clock seconds] - 886400] -format "%Y-%m-%dT00:00:00Z"] 138 | foreach interval [::fogbugz::getList Intervals [dict create token $::token ixPerson $ixPerson dtStart $dtStart]] { 139 | if {![dict exists $interval dtEnd]} { 140 | emit_msg "Automagically set your BUGZID based on the FogBugz current activity for $sFullName" $comments [dict get $interval ixBug] 141 | } 142 | } 143 | emit_msg "There is no current activity in FogBugz for $sFullName" $comments 144 | } 145 | 146 | commit-msg { 147 | if {![is_enabled]} { 148 | exit 149 | } 150 | 151 | lassign $argv ::msgfile 152 | 153 | if {![file exists $::msgfile]} { 154 | bail -1 "Commit message file does not exist: $argv" 155 | } 156 | 157 | set ::commit_msg [load_msg $::msgfile] 158 | 159 | set content 0 160 | foreach line [split $::commit_msg "\n"] { 161 | set line [string trim $line] 162 | if {[string range $line 0 0] != "#"} { 163 | if {$line != "" && ![regexp {BUGZID:(\s+)?(\d+)?(\s+)?$} $line]} { 164 | set content 1 165 | } 166 | } 167 | } 168 | 169 | if {!$content} { 170 | bail -1 "Aborting commit due to empty commit message. (FA)" 171 | } 172 | 173 | bail 174 | } 175 | 176 | default { 177 | bail -1 "Unrecognizing emulation: '$emulation'" 178 | } 179 | } 180 | } 181 | 182 | if !$tcl_interactive { 183 | main $argv 184 | } 185 | -------------------------------------------------------------------------------- /main.tcl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env tclsh8.5 2 | 3 | package require http 4 | package require tdom 5 | package require tls 6 | 7 | ::tls::init -ssl2 0 -ssl3 0 -tls1 1 8 | 9 | namespace eval ::fogbugz { 10 | 11 | proc debug {buf} { 12 | if {$::fogbugz::debug} { 13 | puts $buf 14 | } 15 | } 16 | 17 | proc load_globals {} { 18 | set ::fogbugz::debug 0 19 | 20 | set ::fogbugz::listResult(Filters) {filters filter} 21 | set ::fogbugz::listResult(Intervals) {intervals interval} 22 | set ::fogbugz::listResult(People) {people person} 23 | set ::fogbugz::listResult(Projects) {projects project} 24 | set ::fogbugz::listResult(Areas) {areas area} 25 | set ::fogbugz::listResult(Categories) {categories category} 26 | set ::fogbugz::listResult(Priorities) {priorities priority} 27 | set ::fogbugz::listResult(Statuses) {statuses status} 28 | set ::fogbugz::listResult(FixFors) {fixfors fixfor} 29 | set ::fogbugz::listResult(Mailboxes) {mailboxes mailbox} 30 | set ::fogbugz::listResult(Wikis) {wikis wiki} 31 | set ::fogbugz::listResult(Snippets) {snippets snippet} 32 | } 33 | 34 | proc get_xml {url qs} { 35 | while {![info exists dh]} { 36 | if { [catch {set dh [::http::geturl $url -query $qs]} err] } { 37 | puts "Retrying http geturl: $err" 38 | after 2000 39 | } 40 | } 41 | 42 | set xml [::http::data $dh] 43 | set dom [dom parse $xml] 44 | set doc [$dom documentElement] 45 | 46 | set error [$doc selectNodes {string(/response/error)}] 47 | set code [$doc selectNodes {string(/response/error/@code)}] 48 | $dom delete 49 | 50 | if {$error != ""} { 51 | return [list 0 $xml "$error ($code)"] 52 | } 53 | 54 | return [list 1 $xml] 55 | } 56 | 57 | proc field_expando {buf} { 58 | array set values $buf 59 | 60 | foreach n [array names values "dt*"] { 61 | if {[regexp {(\d\d\d\d-\d\d-\d\d)T(\d\d:\d\d:\d\d)Z} $values($n) _ yyyymmdd hhmmss]} { 62 | append buf " ${n}_epoch [clock scan "$yyyymmdd $hhmmss" -gmt 1]" 63 | } 64 | } 65 | return $buf 66 | } 67 | 68 | 69 | proc login {{api_url ""} {email ""} {password ""}} { 70 | ::http::register https 443 ::tls::socket 71 | load_globals 72 | 73 | if {$api_url != ""} { 74 | set ::fogbugz::config(api_url) $api_url 75 | set ::fogbugz::config(email) $email 76 | set ::fogbugz::config(password) $password 77 | } 78 | 79 | if {![info exists ::fogbugz::config(api_url)]} { 80 | return [list 0 "No FogBugz API URL is configured"] 81 | } 82 | 83 | set qs [::http::formatQuery cmd logon email $::fogbugz::config(email) password $::fogbugz::config(password)] 84 | lassign [get_xml $::fogbugz::config(api_url) $qs] success xml error 85 | 86 | if {!$success} { 87 | return [list 0 $error] 88 | } 89 | 90 | set dom [dom parse $xml] 91 | set doc [$dom documentElement] 92 | set token [$doc selectNodes {string(/response/token)}] 93 | $dom delete 94 | 95 | if {$token != ""} { 96 | set ::fogbugz::config(token) $token 97 | return [list 1 $token] 98 | } 99 | 100 | return [list 0 "Unknown Error"] 101 | } 102 | 103 | proc raw_cmd {cmd {dict ""}} { 104 | set qs [::http::formatQuery cmd $cmd] 105 | if {[info exists ::fogbugz::config(token)] && (![dict exists $dict token] || [dict get $dict token] == "")} { 106 | # If no token supplied to the proc, use the variable one if set 107 | dict set dict token $::fogbugz::config(token) 108 | } 109 | foreach arg [dict keys $dict] { 110 | append qs "&[::http::formatQuery $arg [dict get $dict $arg]]" 111 | } 112 | lassign [get_xml $::fogbugz::config(api_url) $qs] success xml error 113 | if {!$success} { 114 | debug "raw_cmd $cmd ERROR: $error" 115 | } 116 | 117 | return [list $success $xml $error] 118 | } 119 | 120 | proc logoff {{token ""}} { 121 | lassign [raw_cmd logoff [dict create token $token]] success xml error 122 | return [list $success $xml $error] 123 | } 124 | 125 | proc parse_element {element type} { 126 | foreach domNode [split [$element getElementsByTagName *]] { 127 | set field [$domNode nodeName] 128 | set value [$domNode asText] 129 | debug "$field = $value" 130 | if {$value != ""} { 131 | dict set retdict $field $value 132 | } 133 | } 134 | foreach field [split [$element attributes *]] { 135 | set value [$element getAttribute $field] 136 | debug "$field = $value *" 137 | if {$value != ""} { 138 | dict set retdict $field $value 139 | } 140 | } 141 | 142 | foreach attr {data text target} { 143 | catch {dict set retdict $attr [$element $attr]} 144 | } 145 | 146 | if {[info exists retdict]} { 147 | return $retdict 148 | } 149 | 150 | return 151 | } 152 | 153 | proc getList {object {dict ""}} { 154 | if {[info exists ::fogbugz::config(token)] && (![dict exists $dict token] || [dict get $dict token] == "")} { 155 | # If no token supplied to the proc, use the variable one if set 156 | dict set dict token $::fogbugz::config(token) 157 | } 158 | lassign [raw_cmd "list$object" $dict] success xml error 159 | 160 | if {!$success} { 161 | return [list 0 "getList $object ERROR: $error" $xml] 162 | } 163 | 164 | debug "-- $object xml --\n$xml" 165 | set dom [dom parse $xml] 166 | set doc [$dom documentElement] 167 | set selectPath "/[join [concat "response" $::fogbugz::listResult($object)] "/"]" 168 | debug "-- $object selectPath: $selectPath --" 169 | set nodeList [$doc selectNodes $selectPath] 170 | debug "== $object nodeList ==\n$nodeList" 171 | 172 | set returnList [list] 173 | 174 | foreach obj $nodeList { 175 | set retbuf [parse_element $obj [lindex $::fogbugz::listResult($object) end]] 176 | debug $retbuf 177 | lappend returnList [field_expando $retbuf] 178 | } 179 | 180 | $dom delete 181 | 182 | #if {[llength $returnList] == 0} { 183 | # puts "No elements in $object List" 184 | # puts "-- \n$xml\n-- " 185 | #} 186 | 187 | return $returnList 188 | } 189 | 190 | proc search {dict} { 191 | lassign [raw_cmd search $dict] success xml error 192 | 193 | if {!$success} { 194 | return [list 0 "search ERROR: $error" $xml] 195 | } 196 | 197 | debug "-- search xml --\n$xml" 198 | set dom [dom parse $xml] 199 | set doc [$dom documentElement] 200 | set selectPath "/[join {response cases case} "/"]" 201 | debug "-- search selectPath: $selectPath --" 202 | set nodeList [$doc selectNodes $selectPath] 203 | debug "== search nodeList ==\n$nodeList" 204 | 205 | set returnList [list] 206 | 207 | foreach obj $nodeList { 208 | set retbuf [parse_element $obj case] 209 | debug $retbuf 210 | lappend returnList [field_expando $retbuf] 211 | } 212 | 213 | $dom delete 214 | 215 | #if {[llength $returnList] == 0} { 216 | # puts "No elements in search List" 217 | # puts "-- \n$xml\n-- " 218 | #} 219 | 220 | return $returnList 221 | } 222 | 223 | 224 | proc view {object dict} { 225 | lassign [raw_cmd "view$object" $dict] success xml error 226 | 227 | if {!$success} { 228 | return 229 | } 230 | 231 | debug "-- $object xml --\n$xml" 232 | set dom [dom parse $xml] 233 | set doc [$dom documentElement] 234 | set selectPath "/[join [list "response" [string tolower $object]] "/"]" 235 | debug "-- $object selectPath: $selectPath --" 236 | set nodeList [$doc selectNodes $selectPath] 237 | debug "== $object nodeList ==\n$nodeList" 238 | 239 | foreach obj $nodeList { 240 | set retbuf [field_expando [parse_element $obj [string tolower $object]]] 241 | } 242 | debug $retbuf 243 | 244 | return $retbuf 245 | } 246 | 247 | proc whoami {dict} { 248 | set peopleList [getList People $dict] 249 | 250 | if {[info exists ::env(fogbugz_ixPerson)]} { 251 | return $::env(fogbugz_ixPerson) 252 | } 253 | 254 | foreach person $peopleList { 255 | set this_id [dict get $person ixPerson] 256 | set this_person [dict get $person sFullName] 257 | 258 | if {[info exists ::env(USER)] && [regexp $::env(USER) [dict get $person sEmail]]} { 259 | # puts "$this_id based on $::env(USER) matching sEmail [dict get $person sEmail]" 260 | return [list $this_id $this_person] 261 | } 262 | } 263 | 264 | return 0 265 | } 266 | 267 | } 268 | 269 | package provide fogbugz 1.0 270 | --------------------------------------------------------------------------------