#!/usr/bin/env tclsh
# BFG (aka Back/Forward/Go): a no-nonsense Tcl/Tk 8.6+ client for "small web"
# currently supported protocols:
# Gopher (incl. gophers://), Finger, Nex, Spartan, Gemini
# depends on Tk, Tcllib and TclTLS
# created by Luxferre in 2024, released into public domain

package require uri
package require inifile
package require Tk

# overall vars
set tclpath [ file normalize [ info nameofexecutable ] ]
set scriptpath [ file normalize [ info script ] ]
set appdir [ file dirname $scriptpath ]
# check if we're running from a starpack
if [string match *app-bfg $appdir] {
set appdir [ file normalize [ file join $appdir ".." ".." ".." ] ]
}
set config_file [ file join $appdir "bfg.ini" ]

# configuration defaults
set bfg_net_timeout 4000
set bfg_theme "clam"
set bfg_widgetfont "TkDefaultFont"
set bfg_widgetfontsize 16
set bfg_entryfont "TkTextFont"
set bfg_entryfontsize 10
set bfg_statusfont "TkDefaultFont"
set bfg_statusfontsize 10
set bfg_textfont "TkFixedFont"
set bfg_textfontsize 12
set bfg_monofont "TkFixedFont"
set bfg_monofontsize 12
set bfg_main_fgcolor black
set bfg_main_bgcolor white
set bfg_link_fgcolor $bfg_main_fgcolor
set bfg_link_bgcolor $bfg_main_bgcolor
set bfg_focusedlink_fgcolor blue
set bfg_focusedlink_bgcolor $bfg_main_bgcolor
set bfg_highlight_fgcolor $bfg_main_fgcolor
set bfg_highlight_bgcolor yellow
set bfg_error_fgcolor red
set bfg_error_bgcolor $bfg_main_bgcolor
set bfg_tls_support 1

# read configuration from ini
set confini ""
catch {set confini [::ini::open $config_file -encoding utf-8]}
set val ""
set bookmarks ""
if {$confini ne ""} {
set val [::ini::value $confini net timeout $bfg_net_timeout]
if {$val ne ""} {set bfg_net_timeout $val}
set val [::ini::value $confini net tls "on"]
if {$val ne ""} {set bfg_tls_support $val}
set val [::ini::value $confini widget ttkTheme $bfg_theme]
if {$val ne ""} {set bfg_theme $val}
set val [::ini::value $confini widget font $bfg_widgetfont]
if {$val ne ""} {set bfg_widgetfont $val}
set val [::ini::value $confini widget fontsize $bfg_widgetfontsize]
if {$val ne ""} {set bfg_widgetfontsize $val}
set val [::ini::value $confini widget entryfont $bfg_entryfont]
if {$val ne ""} {set bfg_entryfont $val}
set val [::ini::value $confini widget entryfontsize $bfg_entryfontsize]
if {$val ne ""} {set bfg_entryfontsize $val}
set val [::ini::value $confini widget statusfont $bfg_statusfont]
if {$val ne ""} {set bfg_statusfont $val}
set val [::ini::value $confini widget statusfontsize $bfg_statusfontsize]
if {$val ne ""} {set bfg_statusfontsize $val}
set val [::ini::value $confini style.general textfont $bfg_textfont]
if {$val ne ""} {set bfg_textfont $val}
set val [::ini::value $confini style.general textfontsize $bfg_textfontsize]
if {$val ne ""} {set bfg_textfontsize $val}
set val [::ini::value $confini style.general monofont $bfg_monofont]
if {$val ne ""} {set bfg_monofont $val}
set val [::ini::value $confini style.general monofontsize $bfg_monofontsize]
if {$val ne ""} {set bfg_monofontsize $val}
set val [::ini::value $confini style.general foreground $bfg_main_fgcolor]
if {$val ne ""} {set bfg_main_fgcolor $val}
set val [::ini::value $confini style.general background $bfg_main_bgcolor]
if {$val ne ""} {set bfg_main_bgcolor $val}
set val [::ini::value $confini style.link.normal foreground $bfg_link_fgcolor]
if {$val ne ""} {set bfg_link_fgcolor $val}
set val [::ini::value $confini style.link.normal background $bfg_link_bgcolor]
if {$val ne ""} {set bfg_link_bgcolor $val}
set val [::ini::value $confini style.link.focused foreground $bfg_focusedlink_fgcolor]
if {$val ne ""} {set bfg_focusedlink_fgcolor $val}
set val [::ini::value $confini style.link.focused background $bfg_focusedlink_bgcolor]
if {$val ne ""} {set bfg_focusedlink_bgcolor $val}
set val [::ini::value $confini style.highlight foreground $bfg_highlight_fgcolor]
if {$val ne ""} {set bfg_highlight_fgcolor $val}
set val [::ini::value $confini style.highlight background $bfg_highlight_bgcolor]
if {$val ne ""} {set bfg_highlight_bgcolor $val}
set val [::ini::value $confini style.error foreground $bfg_error_fgcolor]
if {$val ne ""} {set bfg_error_fgcolor $val}
set val [::ini::value $confini style.error background $bfg_error_bgcolor]
if {$val ne ""} {set bfg_error_bgcolor $val}

# load bookmarks
if {[::ini::exists $confini bookmarks]} {
foreach key [::ini::keys $confini bookmarks] {
dict set bookmarks $key [::ini::value $confini bookmarks $key]
}
}

# close the ini for now
::ini::close $confini
}

# load TLS support
if {($bfg_tls_support eq "off") || ($bfg_tls_support eq "false" || ($bfg_tls_support eq "none"))} {
set bfg_tls_support 0
} elseif {$bfg_tls_support eq "auto"} {
set bfg_tls_support 2
} else {set bfg_tls_support 1}
if {$bfg_tls_support ne 0} {package require tls}

# generate fonts
foreach fid {widget entry status text mono} {
set vname [string cat bfg_ $fid font]
set ffamily [set $vname]
set fsize [set [string cat $vname size]]
unset -nocomplain $vname
font create $vname -family "$ffamily" -size $fsize -weight normal
}

# logic part

# store browser history here
set bfg_history ""
set bfg_histidx 0

# redirection variables for Spartan and Gemini
set redirectcount 0
set redirectlimit 5

# truncate status characters
proc trunc {s} {
set mlen 60
set nlen [expr { ($mlen / 2) - 1 }]
set len [string length $s]
if {$len > $mlen} {
# truncate characters in the middle
set p1 [string range $s 0 $nlen]
set p2 [string range $s [expr {$len - $nlen}] end]
return [string cat $p1 "…" $p2]
} else {return $s}
}

# common request logic:
# 1) connect via TCP (or TLS)
# 2) send a single data chunk with selector etc
# 3) read the incoming data
# 4) close the connection
proc reqresp {host port reqline is_tls encoding} {
global bfg_response bfg_net_timeout
set sock 0
if {$is_tls eq 1} {
catch {set sock [::tls::socket -autoservername true -async $host $port]}
} elseif {$is_tls eq 2} {
catch {set sock [::tls::socket -autoservername true -async $host $port]}
if {$sock eq 0} {catch {set sock [socket -async $host $port]}}
} else {
catch {set sock [socket -async $host $port]}
}
if {$sock eq 0} {set bfg_response "Connection error"; return}
global rcv_end_$sock
unset -nocomplain rcv_end_$sock
if {$encoding eq ""} {set encoding utf-8}
fconfigure $sock -translation binary -buffering none -encoding $encoding
fileevent $sock writable [list connected $sock $reqline]
proc connected {sock reqline} {
fileevent $sock writable {}
puts -nonewline $sock "$reqline"
flush $sock
fileevent $sock readable [list rdbl $sock]
}
set bfg_response ""
proc rdbl {sock} {
global bfg_response rcv_end_$sock
while {![eof $sock]} {
append bfg_response [read $sock]
}
set rcv_end_$sock 0
}
after $bfg_net_timeout "global rcv_end_$sock; set rcv_end_$sock 1"
vwait rcv_end_$sock
catch {close $sock}
if {"$bfg_response" eq ""} {
set bfg_response "Connection refused or timed out"
}
unset -nocomplain rcv_end_$sock
}

# parse target URL
# returns dictionary {scheme host port path handler}
# uses some hacky http-like logic of Tcllib uri module
proc url2dict {inputurl} {
set out [dict create]
if [regexp {^(.*)://} $inputurl _ lscheme] {
dict set out scheme $lscheme
} else {
dict set out handler "render_handler_invalid"
return $out
}
set rawout [::uri::split [regsub {^.*://} $inputurl "http://"]]
set rhost [dict get $rawout host]
set rpath [dict get $rawout path]
set rport [dict get $rawout port]
set secondarydata [dict get $rawout query]
dict set out host $rhost
set selector $rpath
dict set out handler "render_handler_$lscheme"
# protocol-specific request logic
switch "$lscheme" {
gophers -
gopher {
if {$rport eq ""} {set rport 70}
set selector [string cat [string range $rpath 1 end] "\r\n"]
dict set out handler render_handler_gopher
}
finger {
if {$rport eq ""} {set rport 79}
set selector "$selector\r\n"
}
spartan {
if {$rport eq ""} {set rport 300}
if {$rpath eq ""} {set rpath "/"}
if {![string match "/*" $rpath]} {
set rpath "/$rpath"
}
set blen [string length $secondarydata]
set selector "$rhost $rpath $blen\r\n$secondarydata"
}
nex {
if {$rport eq ""} {set rport 1900}
set selector "$selector\r\n"
}
gemini {
if {$rport eq ""} {set rport 1965}
set selector "$inputurl\r\n"
}
default {dict set out handler render_handler_none}
}
dict set out path $rpath
dict set out selector $selector
dict set out port $rport
return $out
}

# link clicking logic
set linkcount 0
set curlink 0
# all link tracker
set linklist ""
# interactive link tracker (prefixes)
set ilinklist ""
proc clicklink {linknum} {
global bfg_prompt sentry_status linklist ilinklist
set url [lindex $linklist $linknum]
set iprefix [lindex $ilinklist $linknum]
if {$iprefix ne ""} {
grid .sframe.sentry
.sframe.sentry state !disabled
set sentry_status "Prompt from [trunc $url]:"
focus .sframe.sentry
vwait bfg_prompt
.sframe.sentry state disabled
grid remove .sframe.sentry
set url "$url$iprefix$bfg_prompt"
unset -nocomplain bfg_prompt
}
urlfetch $url 1
}

# open link in a new window
proc windowlink {linknum istor} {
global bfg_prompt sentry_status linklist ilinklist
global tclpath scriptpath
set url [lindex $linklist $linknum]
set iprefix [lindex $ilinklist $linknum]
if {$iprefix ne ""} {
grid .sframe.sentry
.sframe.sentry state !disabled
set sentry_status "Prompt from [trunc $url]:"
focus .sframe.sentry
vwait bfg_prompt
.sframe.sentry state disabled
grid remove .sframe.sentry
set url "$url$iprefix$bfg_prompt"
unset -nocomplain bfg_prompt
}
# forward the URL to a new window
if {$istor eq 1} {set epath "torsocks $tclpath"} else {set epath $tclpath}
exec -ignorestderr -- {*}$epath $scriptpath $url &
}

# link downloading logic
proc downloadlink {linknum openExternally} {
global bfg_prompt sentry_status linklist ilinklist
global bfg_status bfg_response
set url [lindex $linklist $linknum]
set iprefix [lindex $ilinklist $linknum]
if {$iprefix ne ""} {
grid .sframe.sentry
.sframe.sentry state !disabled
set sentry_status "Prompt from [trunc $url]:"
focus .sframe.sentry
vwait bfg_prompt
.sframe.sentry state disabled
grid remove .sframe.sentry
set url "$url$iprefix$bfg_prompt"
unset -nocomplain bfg_prompt
}
# get the raw contents in $bfg_response
set scheme [urldl $url 1]
# sanitize the contents for Gemini or Spartan
if {($scheme eq "spartan") || ($scheme eq "gemini")} {
regsub {^\d[^\r].*\r\n} $bfg_response "" bfg_response
}
# get the last part of the URL as suggested filename
set uname [file tail $url]
set outfname [tk_getSaveFile -confirmoverwrite true -initialfile $uname]
if {$outfname ne ""} {
set fp [open $outfname w]
fconfigure $fp -translation binary
puts -nonewline $fp $bfg_response
close $fp
set bfg_response ""
set bfg_status "Downloaded [trunc $url]"
after 2000 {set bfg_status Ready}
if {$openExternally eq 1} {
extOpen $outfname
}
}
}

# link insertion logic
proc linkinsert {textw prevurl rooturl url name iprefix tag} {
global linkcount linklist ilinklist
global contentcursor
global bfg_status bfg_link_fgcolor bfg_link_bgcolor
set linktext "$url"
if {$name ne ""} {
set linktext $name
}
set linktext "=> $linktext"
set tagname "bfglink_$linkcount"
# resolve the url as local if it doesn't contain a scheme
if {[::uri::isrelative "$url"]} {
regexp {^(.*)://} $rooturl _ lscheme
# case 1: it has 2 slashes in the forward, case 2: it has 1 slash
# case 3: it has a suffix on the end, case 4: the rest
if {[string match "//*" "$url"]} {
set url [string cat "$lscheme" ":" "$url"]
} elseif {[string match "/*" "$url"]} {
set url [string cat "$rooturl" "$url"]
} elseif {[regexp {.*/[^/]+$} "$prevurl"]} {
set url [string cat "$prevurl" "/../" "$url"]
} else {
set url [string cat "$prevurl" "/" "$url"]
}
# recanonicalize the URL
set url [regsub {^http://} [::uri::canonicalize [regsub {^.*://} "$url" "http://"]] "$lscheme://"]
}
# handle possible interactive part
set bindcmd "clicklink $linkcount"
set bindcmd2 "windowlink $linkcount 0"
set bindcmd3 "windowlink $linkcount 1"
set bindcmd4 "downloadlink $linkcount 0"
set bindcmd5 "downloadlink $linkcount 1"
lappend ilinklist $iprefix
# perform the insertion
$textw insert end $linktext "$tagname $tag"
$textw tag configure $tagname -underline on -foreground $bfg_link_fgcolor -background $bfg_link_bgcolor
$textw tag bind $tagname <Button-1> $bindcmd
$textw tag bind $tagname <Shift-Button-1> $bindcmd2
$textw tag bind $tagname <Button-2> $bindcmd2
$textw tag bind $tagname <Control-Shift-Button-1> $bindcmd3
$textw tag bind $tagname <Shift-Button-2> $bindcmd3
$textw tag bind $tagname <Button-3> $bindcmd4
$textw tag bind $tagname <Shift-Button-3> $bindcmd5
$textw tag bind $tagname <Enter> "set prev_status \"\$bfg_status\";set bfg_status [trunc \"$url\"];%W configure -cursor hand2"
$textw tag bind $tagname <Leave> {
set bfg_status $prev_status
%W configure -cursor $contentcursor
}
$textw insert end "\n"
# populate the link list
lappend linklist $url
incr linkcount
}

# open unknown protocols in the external OS
proc extOpen {url} {
global tcl_platform
if {$tcl_platform(platform) eq "windows"} {
set command [list {*}[auto_execok start] {}]
if {[file isdirectory $url]} {
set url [file nativename [file join $url .]]
}
} elseif {$tcl_platform(os) eq "Darwin"} {
set command [list open]
} else {
set command [list xdg-open]
}
exec {*}$command $url &
}

# common URL downloader
# return the contents in $bfg_response
proc urldl {inputurl isbinary} {
global bfg_tls_support bfg_response
set parts [url2dict $inputurl]
set host [dict get $parts host]
set port [dict get $parts port]
set path [dict get $parts path]
set selector [dict get $parts selector]
set scheme [dict get $parts scheme]
set is_tls 0
if {($scheme eq "gemini") || ($scheme eq "gophers")} {
if {$bfg_tls_support eq 0} { # report unsupported content
set errmsg {BFG error: TLS support is turned off in the configuration}
if {$scheme eq "gemini"} {
set bfg_response [string cat "50 " $errmsg "\r\n"]
}
if {$scheme eq "gophers"} {
set bfg_response [string cat "3" $errmsg "\t-\t-\t-\r\n"]
}
return $scheme
} else {set is_tls $bfg_tls_support}
}
set encoding "utf-8"
if {$isbinary eq 1} {set encoding "binary"}
reqresp $host $port $selector $is_tls $encoding
return $scheme
}

# common URL fetcher: pass to handler
proc urlfetch {inputurl refhist} {
set parts [url2dict $inputurl]
set handler [dict get $parts handler]
if {$handler eq "render_handler_none"} {
extOpen $inputurl; # attempt to pass the URL to the external OS
} elseif {$handler eq "render_handler_invalid"} {
global linkcount linklist ilinklist curlink bookmarkactive bookmarklabel
set linkcount 0
set curlink 0
set linklist ""
set ilinklist ""
.content.text configure -state normal
.content.text delete 1.0 end; # clear the previous contents
.content.text insert end "Please enter a valid URL"
.content.text configure -state disabled
# append to the history
if {$refhist eq 1} {histappend "about:invalid"}
set bookmarkactive "\u2605"
set bookmarklabel "Add bookmark"
refreshbookmarks
} else {
global bfg_status bfg_response linkcount linklist targeturl
global bfg_history bfg_histidx curlink ilinklist
global bookmarks bookmarkactive bookmarklabel
set bfg_status [trunc "Fetching $inputurl..."]
set linkcount 0
set curlink 0
set linklist ""
set ilinklist ""
set scheme [dict get $parts scheme]
set host [dict get $parts host]
set port [dict get $parts port]
set path [dict get $parts path]
set rooturl "$scheme://$host:$port"
urldl $inputurl 0
# append to the history
if {$refhist eq 1} {histappend $inputurl}
if {$linkcount > 0} {linkfocus 0 1; set curlink 0}
set targeturl $inputurl
wm title . [string cat "BFG - " [trunc $targeturl]]
# update the bookmark character if the URL is bookmarked
if {$targeturl in [dict values $bookmarks]} {
set bookmarkactive "\u2605"
set bookmarklabel "Remove bookmark"
} else {
set bookmarkactive "\u2606"
set bookmarklabel "Add bookmark"
}
set bfg_status [trunc "Rendering $inputurl..."]
.content.text configure -state normal
.content.text delete 1.0 end; # clear the previous contents
# remove all SGR escape sequences for non-downloaded responses
regsub -all {\033\[[0-9;]+m} $bfg_response "" bfg_response
$handler "$inputurl" "$rooturl" "$path" "$bfg_response" .content.text
.content.text configure -state disabled
refreshbookmarks
set bfg_status Ready
focus .content.text
}
}

# plaintext sanitizer: trim every line end
proc textsanitize {text} {
set newtext ""
foreach line [split $text \n] {
set line [string trimright $line]
set newtext [string cat $newtext $line "\n"]
}
return $newtext
}

# link insertion helper
proc widget_linsert {textw prevurl rooturl linkpart prefix tag} {
set llist [split [string trim "$linkpart"]]
set linkurl [lindex $llist 0]
set linkname ""
if {[llength $llist] > 1} {
set linkname [string trim [join [lrange $llist 1 end] " "]]
}
linkinsert $textw "$prevurl" "$rooturl" "$linkurl" "$linkname" "$prefix" "$tag"
}

# Gemtext rendering (for Gemini and Spartan)
# Since BFG displays contents in monospace, only three things
# are processed (per the specification):
# links, preformatting (with optional suffixes) and Spartan's input prompts

proc render_gemtext {textw prevurl rooturl gemtext is_spartan} {
set preformat false
foreach line [split "$gemtext" "\n"] {
set line [string trimright "$line"]
if {[string match "```*" $line]} {; # preformatting mode
set preformat [expr {!$preformat}]
} else {
if {$preformat} {
$textw insert end "$line\n" preformatter
} else {
if {[regexp {^=>(.*)$} $line _ linkpart]} {; # regular link detected
widget_linsert $textw "$prevurl" "$rooturl" "$linkpart" "" ""
} elseif {$is_spartan && [regexp {^=:(.*)$} $line _ linkpart]} {; # input link detected
widget_linsert $textw "$prevurl" "$rooturl" "$linkpart" "?" ""
} else {$textw insert end "$line\n"}
}
}
}
}

# individual protocol rendering handlers

# finger content is just plain text
proc render_handler_finger {prevurl rooturl path body textw} {
$textw insert end [textsanitize $body] preformatter
}

# nex content depends on the path:
# with "" or ending in "/", it is plain text with => links
# otherwise, it's just plain text
proc render_handler_nex {prevurl rooturl path body textw} {
if {$path eq ""} {set path /}
if {[string index $path end] eq "/"} {
foreach line [split $body \n] {
set line [string trimright $line]
if [regexp {^=>\s(.*)$} $line _ linkpart] {; # link detected
widget_linsert $textw $prevurl $rooturl $linkpart "" preformatter
} else {; # normal line
$textw insert end "$line\n" preformatter
}
}
} else {
$textw insert end [textsanitize $body] preformatter
}
}

# gopher content depends on the first character in the selector path
proc render_handler_gopher {prevurl rooturl path body textw} {
if {($path eq "") || ($path eq "/")} {
set gophertype 1
set selector ""
} else {
set gophertype [string index $path 0]
set selector [string range $path 1 end]
}
# for now, let's support TSV gophermaps and treat everything else as plaintext
if {($gophertype eq 1) || ($gophertype eq 7)} {
# get root url scheme, host and port
regexp {^(.*)://} $rooturl _ rootscheme
set parts [::uri::split [regsub {^.*://} $rooturl "http://"]]
set roothost [dict get $parts host]
set rootport [dict get $parts port]
# parse the gophermap body
foreach line [split $body \n] {
set fields [split [string trimright $line] \t]
set l [llength $fields]
set rtype ""
set rdesc ""
set rsel ""
set rhost ""
set rport ""
if {$l > 0} {set rdesc [string trim [lindex $fields 0]]}
if {$l > 1} {set rsel [string trim [lindex $fields 1]]}
if {$l > 2} {set rhost [string trim [lindex $fields 2]]}
if {$l > 3} {set rport [string trim [lindex $fields 3]]}
if {[string length $rdesc] > 0} {
set rtype [string index $rdesc 0]
set rdesc [string range $rdesc 1 end]
if {$l < 2} {
set rsel $rdesc
}
}
# fill in the missing host and port
if {$rhost eq ""} {set rhost $roothost}
if {$rport eq ""} {set rport $rootport}
# update the scheme if the resource is the same
set tscheme gopher
if {($rhost eq $roothost) && ($rport eq $rootport)} {
set tscheme $rootscheme
}
# now we have resource type, description, selector, host and port
# let's output it depending on the type and ignore unknown types
switch $rtype {
0 - 1 - 5 - g - I - : - ";" - < - d - p - s - P - X -
9 { # plain text, gophermap, binary, image, sound...
linkinsert $textw $prevurl $rooturl "$tscheme://$rhost:$rport/$rtype$rsel" $rdesc "" preformatter
}
7 { # gophermap with input
linkinsert $textw $prevurl $rooturl "$tscheme://$rhost:$rport/$rtype$rsel" $rdesc "\t" preformatter
}
8 { # telnet session link
set username ""
if {$rsel ne ""} {set username "$rsel@"}
linkinsert $textw $prevurl $rooturl "telnet://$username$rhost:$rport" $rdesc "" preformatter
}
3 { # error message
$textw insert end "$rdesc\n" {errormsg preformatter}
}
i { # info message
$textw insert end "$rdesc\n" preformatter
}
h { # HTTP URL
regsub ***=URL: $rsel "" clearurl
linkinsert $textw $prevurl $rooturl [string trim $clearurl] $rdesc "" preformatter
}
default {}
}
}
} elseif {($gophertype ne 0) && ($gophertype ne 3)} {
$textw insert end $body preformatter
} else {
$textw insert end [textsanitize $body] preformatter
}
}

# Spartan has a status line in response and multiple MIME types
# we support only text/gemini and text/plain for now
proc render_handler_spartan {prevurl rooturl path body textw} {
global redirectcount redirectlimit
# get the status line
if {[regexp {^([^\n]*)\n} $body _ statusline]} {
set statusline [string trimright $statusline]
set statusparts [split $statusline " "]
set statuscode [lindex $statusparts 0]
set statusinfo [join [lrange $statusparts 1 end] " "]
# reset redirect counter if the code group is not 3
if {$statuscode ne 3} {set redirectcount 0}
if {$statuscode eq 2} { # success - get the remaining body
regsub {.*?\n} $body "" body
if {[string match "text/gemini*" $statusinfo]} {
render_gemtext $textw "$prevurl" "$rooturl" "$body" true
} elseif {[string match "text/plain*" $statusinfo]} {
$textw insert end [textsanitize $body] preformatter
} else {
$textw insert end $body preformatter
}
} elseif {$statuscode eq 3} { # redirect
if {![string match "/*" $statusinfo]} {
set statusinfo "/$statusinfo"
}
set newurl [string cat $rooturl $statusinfo]
if {$redirectcount < $redirectlimit} {
incr redirectcount
urlfetch "$newurl" 0
}
} else { # error
$textw insert end "Error $statuscode: $statusinfo\n"
}
} else {
$textw insert end "Error: empty response from server\n"
}
}

# Gemini is like Spartan but with a separate input logic
# and relative URL support required
proc render_handler_gemini {prevurl rooturl path body textw} {
global redirectcount redirectlimit
if {![string match "/*" "$path"]} {set path "/$path"}
if {[string match "*/" "$rooturl"]} {set rooturl [string range $rooturl 0 end-1]}
set baseurl [string cat "$rooturl" "$path"]
# get the status line
if {[regexp {^([^\n]*)\n} $body _ statusline]} {
set statusline [string trimright $statusline]
set statusparts [split $statusline " "]
set statuscode [lindex $statusparts 0]
set mainstatuscode [string index $statuscode 0]
set statusinfo ""
if {[llength $statusparts] > 1} {
set statusinfo [join [lrange $statusparts 1 end] " "]
}
if {($statuscode < 10) || ($statuscode > 99)} {
$textw insert end "Invalid status code $statuscode: $statusinfo\n" errormsg
return
}
# reset redirect counter if the code group is not 3
if {$mainstatuscode ne 3} {set redirectcount 0}
# we have several code groups
switch $mainstatuscode {
1 { # input required
global sentry_status bfg_prompt
grid .sframe.sentry
.sframe.sentry state !disabled
unset -nocomplain bfg_prompt
set sentry_status "$statusinfo:"
focus .sframe.sentry
vwait bfg_prompt
.sframe.sentry state disabled
grid remove .sframe.sentry
set newurl "$baseurl?$bfg_prompt"
urlfetch "$newurl" 1
}
2 { # success - get the remaining body
regsub {.*?\n} $body "" body
if {[string match "text/gemini*" $statusinfo]} {
render_gemtext $textw "$prevurl" "$rooturl" "$body" true
} elseif {[string match "text/plain*" $statusinfo]} {
$textw insert end [textsanitize $body] preformatter
} else {
$textw insert end $body preformatter
}
}
3 { # redirect
if {[::uri::isrelative $statusinfo]} {
set newurl [string cat $baseurl $statusinfo]
} else {set newurl $statusinfo}
if {$redirectcount < $redirectlimit} {
incr redirectcount
urlfetch "$newurl" 0
}
}
6 { # client certificate status - not supported yet
$textw insert end "The server requires a client certificate — not implemented yet\n"
$textw insert end "Status $statuscode: $statusinfo\n" errormsg
}
default { # error
$textw insert end "Error $statuscode: $statusinfo\n" errormsg
}
}
} else {
$textw insert end "Error: empty response from server\n"
}
}

# history navigation part

proc histappend {inputurl} {
global bfg_history bfg_histidx
set prevurl ""
set previdx [expr {$bfg_histidx - 1}]
if {$bfg_histidx > 0} {
set prevurl [lindex $bfg_history $previdx]
}
if {$inputurl ne $prevurl} {
set bfg_history [lrange $bfg_history 0 $previdx]
lappend bfg_history $inputurl
incr bfg_histidx
.ctrl.back configure -state normal
.ctrl.fwd configure -state disabled
}
}

proc goback {} {
global bfg_history bfg_histidx targeturl
if {$bfg_histidx > 0} {
set newurl [lindex $bfg_history [expr {$bfg_histidx - 2}]]
if {($newurl ne "") && ($newurl ne $targeturl)} {
incr bfg_histidx -1
urlfetch "$newurl" 0
.ctrl.fwd configure -state normal
if {$bfg_histidx < 2} {
.ctrl.back configure -state disabled
}
}
} else {
.ctrl.back configure -state disabled
}
}

proc goforward {} {
global bfg_history bfg_histidx targeturl
set newurl [lindex $bfg_history $bfg_histidx]
if {($newurl ne "") && ($newurl ne $targeturl)} {
incr bfg_histidx
urlfetch "$newurl" 0
.ctrl.back configure -state normal
if {$bfg_histidx >= [llength $bfg_history]} {
.ctrl.fwd configure -state disabled
}
}
}

# in-page text search functionality
set cursearchidx "1.0"
set cursearchpattern ""
proc textsearch {pattern dir isregex} {
global cursearchidx cursearchpattern
global bfg_highlight_bgcolor bfg_highlight_fgcolor
if {("$pattern" eq "") && ("$cursearchpattern" ne "")} {
set pattern "$cursearchpattern"
}
if {("$pattern" ne "$cursearchpattern") && ("$pattern" ne "")} {
set cursearchidx "1.0"
}
set mode {-exact}
if {$isregex} {set mode {-regexp}}
set numdir [expr {int($dir)}]
if {$dir eq -1} {
set dir {-backwards}
} else {set dir {-forwards}}
set fcount 0
set foundidx [.content.text search $mode $dir -nocase -count fcount $pattern $cursearchidx]
.content.text tag delete highlight
if {$foundidx ne ""} {
# add search highlight tag
set endidx "$foundidx + $fcount chars"
.content.text tag add highlight $foundidx $endidx
.content.text tag configure highlight -background $bfg_highlight_bgcolor -foreground $bfg_highlight_fgcolor
.content.text see $foundidx
set cursearchidx "$foundidx + $numdir chars"
set cursearchpattern "$pattern"
} else {set cursearchidx "1.0"}
}

# search GUI action
proc searchui {dir} {
global cursearchidx cursearchpattern
global sentry_status bfg_status bfg_prompt bfg_entry
set prevstatus "$bfg_status"
grid .sframe.sentry
.sframe.sentry state !disabled
unset -nocomplain bfg_prompt
set sentry_status "Search:"
set bfg_entry 1
if {$dir eq -1} {
set sentry_status "Search backwards:"
}
set bfg_status $sentry_status
focus .sframe.sentry
vwait bfg_prompt
.sframe.sentry state disabled
grid remove .sframe.sentry
set bfg_entry 0
textsearch "$bfg_prompt" $dir 0
set bfg_status "$prevstatus"
unset -nocomplain bfg_prompt
}

# Bookmark logic
proc addremovebookmark {url} {
global bookmarks bookmarklabel bookmarkactive
global sentry_status bfg_status bfg_rawprompt bfg_prompt bfg_entry
set urlkey ""
dict for {bkey bval} $bookmarks {
if {$bval eq $url} {
set urlkey $bkey
}
}
if {$urlkey ne ""} { # found the URL, removing the bookmark
set bookmarks [dict remove $bookmarks $urlkey]
set bookmarkactive "\u2606"
set bookmarklabel "Add bookmark"
} else { # adding a new bookmark
set prevstatus "$bfg_status"
grid .sframe.sentry
.sframe.sentry state !disabled
unset -nocomplain bfg_prompt
set sentry_status "Bookmark name:"
set bfg_entry 1
set bfg_status $sentry_status
set bfg_rawprompt $url
focus .sframe.sentry
.sframe.sentry selection range 0 end
vwait bfg_prompt
.sframe.sentry state disabled
grid remove .sframe.sentry
set bfg_entry 0
# we have the name in bfg_prompt
set bname [string trim $bfg_prompt]
dict set bookmarks $bname $url
set bookmarkactive "\u2605"
set bookmarklabel "Remove bookmark"
unset -nocomplain bfg_prompt
set bfg_status "$prevstatus"
set sentry_status ""
}
savebookmarks
refreshbookmarks
}

# save the bookmarks in the configuration INI
proc savebookmarks {} {
global config_file bookmarks
set confini [::ini::open $config_file -encoding utf-8]
::ini::delete $confini bookmarks
dict for {bkname bkurl} $bookmarks {
::ini::set $confini bookmarks $bkname $bkurl
}
::ini::commit $confini
::ini::close $confini
}

# build or refresh bookmark menu
proc refreshbookmarks {} {
global bookmarklabel bookmarks targeturl
.ctrl.bkm.menu delete 0 end
.ctrl.bkm.menu add command -label "$bookmarklabel" -command {addremovebookmark $targeturl}
.ctrl.bkm.menu add separator
dict for {bkname bkurl} $bookmarks {
.ctrl.bkm.menu add command -label "$bkname" -command "urlfetch $bkurl 1"
}
}

# UI part

set contentcursor "left_ptr"
set targeturl ""
if {$argc > 0} {
set targeturl [lindex $argv 0]
}

# set the window title
wm title . "BFG"

# set the window geometry
wm minsize . 800 600

# control bar
set btnwidth 2
set btnpad 2
ttk::frame .ctrl -padding 4
# change this to 2605 when active
set bookmarkactive "\u2606"
set bookmarklabel "Add bookmark"
grid [ttk::button .ctrl.back -text "\u21a9" -width $btnwidth -style bfg.TButton -command {goback}] \
-row 0 -column 0 -sticky nes -padx $btnpad
grid [ttk::button .ctrl.fwd -text "\u21aa" -width $btnwidth -style bfg.TButton -command {goforward}] \
-row 0 -column 1 -sticky nes -padx $btnpad
grid [ttk::button .ctrl.refresh -text "\u21bb" -width $btnwidth -style bfg.TButton -command {urlfetch "$targeturl" 0}] \
-row 0 -column 2 -sticky nes -padx $btnpad
grid [ttk::entry .ctrl.addr -textvariable targeturl -width 40 -font bfg_entryfont] -row 0 -column 3 -sticky nswe -ipadx $btnpad
grid [ttk::menubutton .ctrl.bkm -textvariable bookmarkactive -style bfg.TButton -width $btnwidth -menu .ctrl.bkm.menu] \
-row 0 -column 4 -sticky nws -padx $btnpad
grid columnconfigure .ctrl 3 -weight 1

# bookmarks menu
menu .ctrl.bkm.menu -tearoff 0 -cursor $contentcursor
refreshbookmarks

# main content widget
ttk::frame .content
tk::text .content.text -cursor $contentcursor -yscrollcommand ".content.yscroll set" -wrap word \
-font bfg_textfont -foreground $bfg_main_fgcolor -background $bfg_main_bgcolor -state disabled
ttk::scrollbar .content.yscroll -orient vertical -command ".content.text yview"
grid .content.text -column 0 -row 0 -sticky nsew
grid .content.yscroll -column 1 -row 0 -sticky ns
grid columnconfigure .content 0 -weight 1
grid rowconfigure .content 0 -weight 1

# status bar
ttk::frame .sframe
ttk::label .sframe.status -padding 4 -textvariable bfg_status -font bfg_statusfont
ttk::entry .sframe.sentry -textvariable bfg_rawprompt -state disabled -font bfg_entryfont
grid .sframe.status -column 0 -row 0 -sticky nsew
grid .sframe.sentry -column 1 -row 0 -sticky nsw
grid columnconfigure .sframe 0 -weight 1
set bfg_status Ready

# place them all
grid .ctrl -column 0 -row 0 -sticky nsew
grid .content -column 0 -row 1 -sticky nsew
grid .sframe -column 0 -row 2 -sticky nsew
grid remove .sframe.sentry

# root grid geometry: don't resize the top and bottom row
grid rowconfigure . 1 -weight 1
grid columnconfigure . 0 -weight 1

# iterate over available platform-dependent themes, apply "clam" if none found
catch {ttk::style theme use clam}
catch {ttk::style theme use aqua}
catch {ttk::style theme use winnative}
catch {ttk::style theme use $bfg_theme}

# apply custom styles
ttk::style configure bfg.TButton -font bfg_widgetfont

# set up keybindings

# address entry
bind .ctrl.addr <Return> {urlfetch "$targeturl" 1}
bind .ctrl.addr <FocusIn> {set bfg_entry 1; .ctrl.addr selection range 0 end}
bind .ctrl.addr <FocusOut> {set bfg_entry 0; .ctrl.addr selection clear}
focus .ctrl.addr

# scroll and focus into the numbered link
proc linkfocus {lnum noscroll} {
global bfg_focusedlink_fgcolor bfg_focusedlink_bgcolor
# scroll into the link
set ci [lindex [.content.text tag ranges "bfglink_$lnum"] 0]
if {$noscroll eq 0} {
.content.text see $ci
}
# add highlight tag
set rng [string cat [lindex [split $ci .] 0] ".end"]
.content.text tag delete focuslink
.content.text tag add focuslink $ci $rng
.content.text tag configure focuslink -foreground $bfg_focusedlink_fgcolor -background $bfg_focusedlink_bgcolor
}

# do this on startup
if {$targeturl ne ""} {
.ctrl.addr selection clear
urlfetch "$targeturl" 1
}
set bfg_entry 0
set bfg_rawprompt ""
.ctrl.back configure -state disabled
.content.text tag configure errormsg -foreground $bfg_error_fgcolor -background $bfg_error_bgcolor
.content.text tag configure preformatter -font bfg_monofont

# general keybinding switch

bind . <Key> {
if {$bfg_entry eq 0} {
switch "%K" {
g {focus .ctrl.addr}
F5 -
r {urlfetch "$targeturl" 0}
default {}
b {goback}
f {goforward}
Prior -
Left -
h {.content.text yview scroll -1 pages}
Next -
Right -
l {.content.text yview scroll 1 pages}
Down -
j {.content.text yview scroll 1 units}
Up -
k {.content.text yview scroll -1 units}
a { # select previous link
if {$linkcount > 0} { # we have some links
incr curlink -1
if {$curlink < 0} {
set curlink [expr {$linkcount - 1}]
}
linkfocus $curlink 0
set vurl [lindex $linklist $curlink]
set bfg_status "=> [trunc $vurl]"
}
}
s { # select next link
if {$linkcount > 0} { # we have some links
incr curlink
if {$curlink >= $linkcount} {
set curlink 0
}
linkfocus $curlink 0
set vurl [lindex $linklist $curlink]
set bfg_status "=> [trunc $vurl]"
}
}
space -
Return { # visit the focused link
if {$linkcount > 0} { # we have some links
.content.text tag delete focuslink
clicklink $curlink
}
}
d { # download the focused link
if {$linkcount > 0} { # we have some links
downloadlink $curlink 0
}
}
D { # download the focused link and open it externally
if {$linkcount > 0} { # we have some links
downloadlink $curlink 1
}
}
Escape { # reset search highlights
set cursearchpattern ""
set cursearchidx "1.0"
.content.text tag delete highlight
}
slash {searchui 1}
default {}
}
}
}

bind . <Shift-space> {
if {$linkcount > 0} { # we have some links
windowlink $curlink 0
}
}

bind . <Shift-Return> {
if {$linkcount > 0} { # we have some links
windowlink $curlink 0
}
}

bind . <Control-Shift-space> {
if {$linkcount > 0} { # we have some links
windowlink $curlink 1
}
}

bind . <Control-Shift-Return> {
if {$linkcount > 0} { # we have some links
windowlink $curlink 1
}
}

# generic mouse click events
# 1 - left, 2 - mid, 3 - right, 8 - back, 9 - forward
bind . <Button> {
if {$bfg_entry eq 0} {
switch "%b" {
8 {goback}
9 {goforward}
default {}
}
}
}

# status entry
bind .sframe.sentry <Return> {
set bfg_prompt "$bfg_rawprompt"
set bfg_rawprompt ""
}
bind .sframe.sentry <Enter> {
if {$sentry_status ne ""} {
set bfg_status [trunc "$sentry_status"]
}
}
bind .sframe.sentry <FocusIn> {
set bfg_entry 1
if {$sentry_status ne ""} {
set bfg_status [trunc "$sentry_status"]
}
}
bind .sframe.sentry <FocusOut> {
set bfg_entry 0
}

# search
bind . <Control-f> {searchui 1}
bind . <Control-F> {searchui -1}
bind . <Control-slash> {searchui -1}

# bookmark menu
bind . <Control-b> {event generate .ctrl.bkm <Button-1>}

# exit
bind . <Control-q> {exit 0} 