Updated 2013-02-08 17:09:59 by mw

Reinhard Max - 2004-11-08

This little tool is another example of web scraping. It allows one to create a tiny URL (http://tinyurl.com) from the command line.

The TinyURL proc can also be used in other scripts for TinyURL creation.
 package require http

 # - TinyURL
 # 
 #  Create a simple alias URL from a possibly long and complicated one
 #  using the http://tinyurl.com service
 #
 # in:  The URL to be made tiny
 # out: The tiny URL
 #
 proc TinyURL {url} {
    set query [::http::formatQuery url $url]
    set token [::http::geturl http://tinyurl.com/create.php -query $query]
    if {[::http::ncode $token] != 200} {
        return -code error [::http::data $token]
    }
    set RE {^<input type=hidden name=tinyurl value="(.*)">$}
    if {![regexp -line $RE [::http::data $token] -> turl]} {
        return -code error \
            "http://tinyurl.com has probably changed the output format."
    }
    ::http::cleanup $token
    return $turl
 }

 if {$argc != 1} {
    puts "usage: [info script] url"
    exit 1
 }

 puts [TinyURL [lindex $argv 0]]

MG The output format does indeed seem to have changed since this was written - replacing the regexp line with
  set RE {<blockquote><b>(.+?)</b>}

seems to get it going again now. (Though, the comments in the HTML code ask you not to web scrape, and to contact them about their API instead - I just emailed, will try and comment here again when I hear back, hopefully it'll be something that can be done simply in Tcl like the above.)

AF: I added an example for using bit.ly to the tcllib rest module [1] which may be a good alternative

[mw]: This example uses the tinyurl API instead. Consider it public domain. 2013-02-08
proc tinyurl {url} {
        set result {}
        set query [::http::formatQuery url $url]
        catch {
                set tok [::http::geturl "http://tinyurl.com/api-create.php" -query $query]
                upvar #0 $tok state
                if {$state(status) == "ok" && $state(type) == "text/plain"} {
                        set result [lindex [split $state(body) \n] 0]
                }
                ::http::cleanup $tok
        }
        return $result
}