TrackBackは自サイトからリンクしていることを相手のサイトに伝える仕組みで、 MovableTypeなどのWebLogシステムで実装されています。
以下はTclによるTrackBackの送信の実装例です。 与えられたtargeturiからそれに対応するTrackBack Ping URLを自動検知し、 Pingを送信します。
# Tcl による TrackBack Ping の送信
package require http
package require htmlparse
proc escape {str} {
regsub -all {\&} $str {\&} str
regsub -all {\<} $str {\<} str
regsub -all {\>} $str {\>} str
regsub -all {\"} $str {\"} str
return $str
}
proc unescape {str} {
regsub -all {\<} $str {\<} str
regsub -all {\>} $str {\>} str
regsub -all {\"} $str {\"} str
regsub -all {\&} $str {\&} str
return $str
}
set targeturi "http://.../mt/archives/000001.html"
set sourceuri "http://..."
set title "sourceuriの記事のタイトル"
set excerpt "要約"
set blog_name "ウェブログの名前"
set enc "euc-jp"
regexp {(^[^#]+)} $targeturi match requesturl
set token [::http::geturl $requesturl]
upvar #0 $token state
set pingurl ""; set cur 0
while {[set cur [string first {<rdf:RDF} $state(body) $cur]] != -1} {
set endtag {</rdf:RDF>}
set end [expr [string first $endtag $state(body) $cur] + [string length $endtag] - 1]
set rdf [string range $state(body) $cur $end]
regexp {\sdc:identifier="([^"]+)"} $rdf match identifier
set identifier [unescape $identifier]
if {$identifier == $targeturi || $identifier == $requesturl} {
regexp {\strackback:ping="([^"]+)"} $rdf match pingurl
set pingurl [unescape $pingurl]
}
set cur [incr end]
}
if {$pingurl == ""} {
puts "TrackBack Ping URL not found"
exit
}
set request [::http::formatQuery \
url [encoding convertto $enc $sourceuri] \
title [encoding convertto $enc $title] \
excerpt [encoding convertto $enc $excerpt] \
blog_name [encoding convertto $enc $blog_name] \
]
set token [::http::geturl $pingurl -query $request]
upvar #0 $token state
set pingresult 1
# レスポンスは XML だがとりあえず HTML パーサで解析
proc detecterror {tag slash param textBehindTheTag} {
global pingresult
if {$tag =="error" && $slash == ""} {
set pingresult $textBehindTheTag
}
}
::htmlparse::parse -cmd detecterror $state(body)
if {$pingresult == 0} {
puts "success"
} else {
puts "error"
}