some gemini compat improvements

bfg.tcl

@@ -121,6 +121,10 @@ foreach fid {widget entry status text mono} {
 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
@@ -336,7 +340,7 @@ proc linkinsert {textw prevurl rooturl url name iprefix tag} {
       set url [string cat "$lscheme" ":" "$url"]
     } elseif {[string match "/*" "$url"]} {
       set url [string cat "$rooturl" "$url"]
-    } elseif {[string match {*/*.???} "$prevurl"]} {
+    } elseif {[regexp {.*/[^/]+$} "$prevurl"]} {
       set url [string cat "$prevurl" "/../" "$url"]
     } else {
       set url [string cat "$prevurl" "/" "$url"]
@@ -439,14 +443,8 @@ proc urlfetch {inputurl refhist} {
     set path [dict get $parts path]
     set rooturl "$scheme://$host:$port"
     urldl $inputurl 0
-    set bfg_status [trunc "Rendering $inputurl..."]
-    .content.text configure -state normal
-    .content.text delete 1.0 end; # clear the previous contents
-    $handler "$inputurl" "$rooturl" "$path" "$bfg_response" .content.text
-    .content.text configure -state disabled
     # append to the history
     if {$refhist eq 1} {histappend $inputurl}
-    # finalize
     if {$linkcount > 0} {linkfocus 0 1; set curlink 0}
     set targeturl $inputurl
     wm title . [string cat "BFG - " [trunc $targeturl]]
@@ -458,6 +456,11 @@ proc urlfetch {inputurl refhist} {
       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
+    $handler "$inputurl" "$rooturl" "$path" "$bfg_response" .content.text
+    .content.text configure -state disabled
     refreshbookmarks
     set bfg_status Ready
     focus .content.text
@@ -620,12 +623,15 @@ proc render_handler_gopher {prevurl rooturl path body textw} {
 # 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} $body _ statusline]} {
+  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]} {
@@ -640,7 +646,10 @@ proc render_handler_spartan {prevurl rooturl path body textw} {
         set statusinfo "/$statusinfo"
       }
       set newurl [string cat $rooturl $statusinfo]
-      urlfetch "$newurl" 0
+      if {$redirectcount < $redirectlimit} {
+        incr redirectcount
+        urlfetch "$newurl" 0
+      }
     } else { # error
       $textw insert end "Error $statuscode: $statusinfo\n"
     }
@@ -652,16 +661,26 @@ proc render_handler_spartan {prevurl rooturl path body textw} {
 # 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} $body _ statusline]} {
+  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 [join [lrange $statusparts 1 end] " "]
+    set statusinfo ""
+    if {[llength $statusparts] > 1} {
+      set statusinfo [join [lrange $statusparts 1 end] " "]
+    }
+    if {($statuscode < 10) || ($statuscode > 100)} {
+      $textw insert end "Error $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
@@ -691,7 +710,10 @@ proc render_handler_gemini {prevurl rooturl path body textw} {
         if {[::uri::isrelative $statusinfo]} {
           set newurl [string cat $baseurl $statusinfo]
         } else {set newurl $statusinfo}
-        urlfetch "$newurl" 0
+        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"