Picture of the Day Demo

Keith Vetter - 2023-08-30: A few days ago I posted Picture of the Day, a module that lets you download pictures from either Wikipedia's or Wikimedia Commons' Picture of the Day. That code contained a CLI demo showing how to use the module.

Here is a GUI demo exercising the Picture of the Day module.

This demo requires that module. You can either download and save it as "wiki_potd.tcl". Alternatively, this demo can download the code off the Wiki and install it directly. To be safe, the demo fetches the Wiki page, scrapes the code and evaluates it in a safe interpreter. It then extracts the functionality from the safe interpeter.

Jeff Smith 2023-09-01 : Below is an online demo using CloudTk. This demo runs “Picture of the Day Demo” in an Alpine Linux Docker Container. It is a 29.2MB image which is made up of Alpine Linux + tclkit + Picture-of-the-Day-Demo.kit + tls1.7.18 + libx11 + libxft + fontconfig. It is run under a user account in the Container. The Container is restrictive with permissions for "Other" removed for "execute" and "read" for certain directories.

N.B This demo is better viewed in Full Screen mode via the noVNC tab at the side of the window.

# wiki_pod_demo.tcl -- shows off how to use wiki_potd module
# Requires the "Picture of the Day" module. You can either download it
# from https://wiki.tcl-lang.org/page/Picture+of+the+Day (save it as
# wiki_potd.tcl), or this demo can download and install from the web.
# (It does so safely by using a safe interpreter).
# by Keith Vetter 2023-08-02
package require Tk
package require Img
package require http
package require tls
http::register https 443 [list ::tls::socket -tls1 1]
package require tdom

set module_name wiki_potd.tcl

set text_font [concat [font actual TkDefaultFont] -size 15]
set big_font [concat [font actual TkDefaultFont] -size 18]
set big_bold_font [concat [font actual TkDefaultFont] -size 18 -weight bold]

proc Main {} {
    GetNewImage Commons
proc DoDisplay {} {
    wm title . "Wikipedia Picture of the Day Demo"
    image create photo ::img::img -width 500 -height 500
    ::ttk::label .img -image ::img::img -borderwidth 3 -relief ridge
    ::ttk::label .desc -textvariable ::DESC -borderwidth 0 -relief ridge -anchor center \
        -justify center -font $::big_font
    ::ttk::frame .left
    text .log -height 3 -font $::text_font -width 0 -bd 3 -relief ridge -wrap word
    .log tag config title -font $::big_bold_font
    .log insert end "Welcome to Wiki Picture of the Day Demo" title
    grid .left .img -sticky news
    grid ^ .desc -sticky news
    grid .log - -sticky news -row 10
    grid rowconfigure . 10 -weight 1

    ::ttk::frame .left.new -relief raised -borderwidth 3 -padding {0 0 0 .1i}
    ::ttk::label .left.new.l -text "Random POTD Image" -font $::text_font
    ::ttk::button .left.new.w -text "Wikipedia" -command [list GetNewImage Wikipedia]
    ::ttk::button .left.new.c -text "Commons" -command [list GetNewImage Commons]
    grid .left.new.l -sticky ew -pady {0 .05i}

    grid .left.new.w
    grid .left.new.c

    ::ttk::button .left.save -text Save -command SaveImage
    grid .left.new -row 1 -pady .2i -padx .2i
    grid rowconfigure .left 100 -weight 1
    grid .left.save -row 101 -pady .2i

proc ClearOldSizes {} {
    foreach w [winfo child .left] {
        if {$w ne ".left.new" && $w ne ".left.save"} {
            destroy $w
    destroy .mf

proc GetNewImage {service} {
    destroy .mf
    GuiLogger "====================="
    ::img::img blank
    set ::DESC "fetching new $service POTD..."

    set maxWidth [expr {[winfo screenwidth .] * .5}]
    set maxHeight [expr {[winfo screenheight .] * .8}]
    set fitness [list $maxWidth $maxHeight]

    lassign [::POTD::RandomPOTD $service $fitness] ::meta ::all
    UpdateGUI $::meta $::all
proc UpdateGUI {meta all} {

    set date [dict get $meta date]
    set pdate [clock format [clock scan $date -format "%Y/%m/%d"] -format "%B %d, %Y"]
    set service [dict get $meta service]
    set row 2
    ::ttk::label .left.l_$row -text "$service POTD\n$pdate" -anchor c -justify c
    grid .left.l_$row -row $row -sticky ew

    if {$all eq {}} {
        ::ttk::label .left.nothing -text "No sizes found" -anchor c
        set bestfit -1
    } else {
        foreach item $all {
            incr row
            lassign $item width height url
            set w ".left.b_$row"
            set txt "[Comma $width] x [Comma $height]"
            ::ttk::button $w -text $txt -command [list ShowImage $width $height $url]
            grid $w -row $row -sticky ew
    set bestfit [dict get $meta bestfit]
    if {$bestfit != -1} {
        ShowImage {*}[lindex $all $bestfit]
        lassign [lindex $all $bestfit] width height _
        set size " ([Comma $width] x [Comma $height])"
    } else {
        image create photo ::img::img -width 500 -height 500
        ::img::img put seashell -to 0 0 500 500
        MessageBox [dict get $meta desc]
        set ::img_data ""
        set size ""
    set desc [string trim [dict get $meta desc]]
    set first [FirstSentence $desc]
    set ::DESC "$first\n$service POTD for $pdate$size"
    GuiLogger "$desc\n$service POTD for $pdate$size"
proc FirstSentence {para} {
    set n [string first "." $para]
    if {$n == [string length $para] - 1} {
        return $para
    # https://stackoverflow.com/questions/3788220/extract-first-sentence-from-string-of-text
    set re {(^.*?[a-z0-9\)]{2,}[.!?])\s+\W*[A-Z]}
    set n [regexp $re $para _ sentence]
    if {$n} { return $sentence }
    return $para
proc Comma {num} {
    while {[regsub {^([-+]?[0-9]+)([0-9][0-9][0-9])} $num {\1,\2} num]} {}
    return $num
proc GuiLogger {msg} {
    .log insert end "\n\u2022 $msg"
    .log see end
proc ShowImage {width height url} {
    set ::img_data [::POTD::DownloadUrl $url]
    image delete ::img::img
    image create photo ::img::img -data $::img_data
    .desc config -wraplength [image width ::img::img]
    GuiLogger "Showing [Comma $width] x [Comma $height]"
proc SaveImage {} {
    if {$::img_data eq ""} return
    set service [dict get $::meta service]
    set service [string tolower [string index $service 0]]
    set date [regsub -all "/" [dict get $::meta date] "_"]
    set fname "potd_${service}_${date}.jpg"
    set fout [open $fname wb]
    puts -nonewline $fout $::img_data
    close $fout
    set w [MessageBox "Saved image to $fname"]
    after 3000 [list destroy $w]
proc MessageBox {msg} {
    destroy .mf
    ::ttk::frame .mf -borderwidth 3 -relief groove
    ::ttk::label .mf.l -text $msg -font $::big_bold_font
    ::ttk::button .mf.b -text Ok -command {destroy .mf}

    grid .mf.l -padx .4i -pady .4i
    grid .mf.b -pady .2i

    place .mf -in .img -relx .5 -rely .5 -anchor c
    return .mf
proc ErrorBox {msg details} {
    tk_messageBox -message $msg -detail $details -icon error -title "Wiki Potd Demo" \
        -parent .
    exit 1

namespace eval ::WikiPotD {
    # Code to fetch from tcler's Wiki "Picture of the Day" code

    variable url https://wiki.tcl-lang.org/page/Picture+of+the+Day
    variable fname $module_name

proc ::WikiPotD::Load {} {
    variable fname
    variable url

    set fullname [::WikiPotD::_Search $fname]
    if {$fullname ne ""} {
        GuiLogger "Loading Wiki PotD module from $fname"
        source $fname
    set msg "Module Wiki PotD not found"
    set details "It can be found at $url\n\n"
    append details "Do you want to download and install it (safely) from the web?"

    set resp [tk_messageBox -message $msg -detail $details -icon question \
                  -title "Wiki Potd Demo" -type yesno -parent .]
    if {$resp ne "yes"} {
        puts stderr "Download module Wiki PotD from $url"
        exit 1

    set code [::WikiPotD::_Fetch]
    ::WikiPotD::_SafeLoadCode $code
proc ::WikiPotD::_Search {fname} {
    GuiLogger "Searching for Wiki PotD module"
    set dirs [list . .. [file dirname [file normalize $::argv0]]]
    foreach dir $dirs {
        set fullname [file join $dir $fname]
        if {[file exists $fullname]} { return $fullname }
    return ""

proc ::WikiPotD::_Fetch {} {
    variable url

    set html [::WikiPotD::_DownloadUrl $url]
    set code [::WikiPotD::_ExtractCode $html]
    return $code

proc ::WikiPotD::_DownloadUrl {url} {
    # Downloads a given URL

    GuiLogger "Fetching tcler's Wiki page for Picture of the Day"
    set token [::http::geturl $url]
    set html [::http::data $token]
    set ncode [::http::ncode $token]
    ::http::cleanup $token

    if {$ncode != 200} {
        ErrorBox "Error Installing Wiki POTD" "Failed to download $url with code $ncode"
    return $html
proc ::WikiPotD::_ExtractCode {html {index 1}} {
    set n [catch {set dom [::dom parse -html $html]}]
    if {$n} {ErrorBox "Error Installing Wiki POTD" "Bad HTML: $emsg" }

    GuiLogger "Scraping Wiki page for code section"
    set xpath {//pre[contains(@class, "sh_sourceCode")]}
    set code_nodes [$dom selectNodes $xpath]

    set cnt [llength $code_nodes]
    if {$cnt == 0} {
        ErrorBox "Error Installing Wiki POTD" "Scraping error: No code sections found"
    set code [[lindex $code_nodes $index-1] asText]
    return $code
proc ::WikiPotD::_SafeLoadCode {code} {
    # Evaluates $code in a safe interpreter then extracts the good stuff

    set in [interp create -safe]
    interp expose $in source
    interp eval $in { proc package {args} {} }
    interp eval $in { namespace eval ::http {} }
    interp eval $in { proc ::http::register {args} {} }
    interp eval $in [list eval $code]

    namespace eval ::POTD {}
    set vars [interp eval $in {info vars ::POTD::* }]
    foreach var $vars {
        # If any var is an array then this code breaks
        set value [interp eval $in [list set $var]]
        set $var $value
        # puts "set $var $value"
    set funcs [interp eval $in {info procs ::POTD::* }]
    foreach func $funcs {
        # puts "CopyProc \$in $func"
        ::WikiPotD::_CopyProc $in $func

    interp delete $in
proc ::WikiPotD::_CopyProc {in pname} {
    set args {}
    foreach arg [interp eval $in info args $pname] {
        if {[interp eval $in info default $pname $arg _default_]} {
            set default [interp eval $in set _default_]
            lappend args [list $arg $default]
        } else {
            lappend args $arg
    set body [interp eval $in info body $pname]
    uplevel "#0" [list proc $pname $args $body]

if {$tcl_interactive} return
::POTD::SetLogger GuiLogger