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

<<inlinehtml>>

<iframe height="750" width="1050" src="https://cloudtk.tcl-lang.org/cloudtk/VNC?session=new&Tk=Picture-of-the-Day-Demo" allowfullscreen></iframe>

<<inlinehtml>>

----


======
##+##########################################################################
#
# 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

======