[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.


======
##+##########################################################################
#
# 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} {
    ClearOldSizes

    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
        return
    }
    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
DoDisplay
::WikiPotD::Load
::POTD::SetLogger GuiLogger
Main

======