#!/usr/bin/tclsh

# 
# file: rssreader.tcl
# 
# Minimalistic RSS reader
# Prerequisites: package XML by wdb
# external tools:
# wget
# Any web browser
# 
# Customize browser command:
# variable browserCommand
# 
# Costomize feeds:
# see procedure setMenu below
# 
# caveats: tested on Linux
# should work on Windows as well if wget is present
# 

#
# customize path for packages, care that package XML is present
#
::tcl::tm::path add ~/bin/TM

package require XML

# variable browserCommand opera
# variable browserCommand "chromium-browser -new-window"
variable browserCommand "firefox -new-window"

proc wget url {
  exec wget -q -O - $url
}

proc rssLinks tree {
  set paths [xml findElementsByName $tree item]
  set result {}
  foreach path $paths {
    set item [xml getElement $tree {*}$path]
    lassign [xml findElementsByName $item link] linkPath
    lassign [xml findElementsByName $item title] titlePath
    lappend result\
      [string trim [xml getText $item {*}$titlePath]]\
      [xml getText $item {*}$linkPath]
  }
  set result
}

proc atomLinks tree {
  global entry linkElement paths
  set paths [xml findElementsByName $tree entry]
  set result {}
  foreach path $paths {
    set entry [xml getElement $tree {*}$path]
    lassign [xml findElementsByName $entry title] titlePath
    lappend result\
      [string trim [xml getText $entry {*}$titlePath]]
    set paths [xml findElementsByName $entry link]
    foreach path $paths {
      set linkElement [xml getElement $entry {*}$path]
      if {[dict exists $linkElement attribute rel] &&
          [dict get $linkElement attribute rel] eq "alternate"} break
    }
    lappend result [dict get $linkElement attribute href]    
  }
  set result
}

proc readLinks url {
  set tree [xml parse [wget $url]]
  switch -exact -- [dict get $tree name] {
    rss {
      rssLinks $tree
    }
    feed {
      atomLinks $tree
    }
    default {
      return -code error "[info level 0] -- unkown [dict get $tree name]"
    }
  }
}

# window

package require Tk
bind [winfo class .] <Destroy> exit

destroy .h .v .t
text .t\
  -font {Times 14}\
  -cursor hand1\
  -wrap none\
  -highlightthickness 0\
  -foreground navy\
  -background LightYellow1\
  -yscrollcommand {.v set}\
  -xscrollcommand {.h set}
scrollbar .v\
  -orient vertical\
  -command {.t yview}
scrollbar .h\
  -orient horizontal\
  -command {.t xview}
place .t\
  -anchor nw\
  -relheight 1.0\
  -height -[winfo reqheight .h]\
  -relwidth 1.0\
  -width -[winfo reqwidth .v]
place .v\
  -relx 1.0\
  -anchor ne\
  -relheight 1.0\
  -height -[winfo reqheight .h]
place .h\
  -rely 1.0\
  -anchor sw\
  -relwidth 1.0\
  -width -[winfo reqwidth .v]

bind . <FocusIn> {focus .t}
bind .t <Control-plus> {
  apply {
    win {
      set font [$win cget -font]
      lassign $font family size
      if {$size < 18} then {
        $win configure -font [list $family [incr size]]
      }
    }
  } %W
}
bind .t <Control-minus> {
  apply {
    win {
      set font [$win cget -font]
      lassign $font family size
      if {$size > 8} then {
        $win configure -font [list $family [incr size -1]]
      }
    }
  } %W
}
bind .t <Control-0> {
  %W configure -font "Times 14"
}

wm title . RSS-Reader
wm geometry . 400x300
.t replace 1.0 end " RSS-Feed mit Kontextmenü auswählen!

 Choose RSS feed with context menu!"
.t configure -state disabled

proc setLinks url {
  variable browserCommand
  .t delete 1.0 end
  foreach {text href} [readLinks $url] {
    .t insert insert " $text " href[incr i] \n {}
    .t tag configure href$i -borderwidth 2 -background [.t cget -background]
    .t tag bind href$i <Enter>\
      ".t tag configure href$i -foreground red"
    .t tag bind href$i <Leave>\
      ".t tag configure href$i -foreground {} -background {}"
    .t tag bind href$i <1> "
      .t tag configure href$i\
        -relief sunken -background LightYellow2 -foreground black
      update
      exec {*}$browserCommand [string map {&amp; & % %%} $href] &
    "
    .t tag bind href$i <ButtonRelease> "
      after 1500 [list .t configure -cursor [.t cget -cursor]]
      .t tag configure href$i\
        -relief flat -background [.t cget -background] -foreground red
      .t tag remove sel 1.0 end
      .t configure -cursor watch
    "
  }
}

proc setRSS {name url} {
  wm title . "Feed: $name"
  .t configure -state normal
  .t replace 1.0 end " $url"
  tk busy .t
  update
  tk busy forget .t
  setLinks $url
  .t delete end-1chars
  .t configure -state disabled
}

menu .m
bind .t <3> {tk_popup .m %X %Y}

proc setMenu {l {menu .m}} {
  destroy $menu
  menu $menu
  foreach {action label what} $l {
    switch -exact -- $action {
      command {
        $menu add command\
          -label $label\
          -command [list setRSS $label $what]
      }
      menu {
        $menu add cascade\
          -label $label\
          -menu [setMenu $what $menu.[incr i]]
      }
    }
  }
  set menu
}

setMenu {
  command Pollmer https://podcast.euleev.de/eule.xml
  command Tagebuch http://wolf-dieter-busch.de/blog/rss.xml
  command "Russland aktuell" https://www.fit4russland.com/?format=feed&type=rss
  command fefe http://blog.fefe.de/rss.xml?html
  command Telepolis https://www.heise.de/tp/news-atom.xml
  menu Law {
    command Lawblog http://www.lawblog.de/index.php/feed/
    command Richtersicht http://www.richtersicht.de/feed/
    command Kompa https://kanzleikompa.de/feed/
    command WBS https://www.wbs-law.de/feed/
  }
  menu Newspaper {
    command Cicero https://www.cicero.de/rss.xml
    menu NZZ {
      command Neues http://www.nzz.ch/recent.rss
      command International http://www.nzz.ch/international.rss
      command Wissenschaft http://www.nzz.ch/wissenschaft.rss
    }
    command taz http://taz.de/rss.xml
    command RT-Deutsch https://deutsch.rt.com/feeds/news/
  }
}