home/mtinyurl.tcl

   1 #! /bin/sh
   2 # -*- tcl -*- \
   3 exec tclsh "$0" ${1+"$@"}
   4
   5 # Script to create a short url via http://tinyurl.com
   6 # right away from the command line.
   7
   8 #   Copyright (c) 2007  Sven Hoexter <sven@timegate.de>
   9 #
  10 #   This program is free software; you can redistribute it and/or modify
  11 #   it under the terms of the GNU General Public License as published by
  12 #   the Free Software Foundation; either version 2 of the License, or
  13 #   (at your option) any later version.
  14 #
  15 #   This program is distributed in the hope that it will be useful,
  16 #   but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 #   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 #   GNU General Public License for more details.
  19 #
  20 #   You should have received a copy of the GNU General Public License
  21 #   along with this program; if not, write to the Free Software
  22 #   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA
  23
  24 # For updates see http://sven.stormbind.net/misc/
  25
  26 ### Changelog
  27 # Version: 0.1 2007-04-15
  28 #  - initial release
  29
  30 ### required external (Debian) packages are:
  31 # - tclcurl for TclCurl
  32 # - tcllib for htmlparse etc.
  33
  34 package require TclCurl
  35 package require http
  36 package require htmlparse
  37 package require struct
  38
  39 proc parse {rpage} {
  40     ::struct::tree t
  41     htmlparse::2tree $rpage t
  42     htmlparse::removeVisualFluff t
  43     htmlparse::removeFormDefs t
  44     foreach nodeakt [t children -all [t rootname]] {
  45         #puts "DEBUG: [t getall $nodeakt ] NODE: $nodeakt"
  46         if {[t get $nodeakt type] == "PCDATA"} {
  47             set nodedata [t get $nodeakt data]
  48             if {[string match -nocase "*http://tinyurl.com*" $nodedata]} {
  49                 puts $nodedata
  50                 puts ""
  51             }
  52         }
  53     }
  54 }
  55
  56
  57 proc main {argv} {
  58     #puts "DEBUG: $argv"
  59     regsub -all "(http://)" $argv "" saneargv
  60     #puts "DEBUG: $saneargv"
  61     set useragent "Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.7.12) Gecko/20050922"
  62     set uri http://tinyurl.com/create.php?
  63     append uri [http::formatQuery url $saneargv]
  64     #puts "DEBUG: $uri"
  65
  66     set chandle [curl::init]
  67     $chandle configure -url $uri \
  68         -useragent $useragent \
  69         -autoreferer 1 \
  70         -followlocation 1 \
  71         -bodyvar rpage
  72     $chandle perform
  73     $chandle cleanup
  74
  75     parse $rpage
  76 }
  77
  78 main $argv