#!/usr/bin/tclsh8.0

# (find-angg "TH/Generate")

# «.functional»		(to "functional")
# «.proc1_procj»	(to "proc1_procj")
# «.basic_html»		(to "basic_html")
# «.encode_entities»	(to "encode_entities")
# «.local_remote_modes»	(to "local_remote_modes")
# «.boolean_env_vars»	(to "boolean_env_vars")
# «.local_remote_urls»	(to "local_remote_urls")
# «.LR_modifiers»	(to "LR_modifiers")
# «.file_IO»		(to "file_IO")
# «.relative_links»	(to "relative_links")
# «.extra_utils»	(to "extra_utils")
# «.templates»		(to "templates")



#%%%%
#
# Routines with a functional taste
#
#%%%%

# «functional»  (to ".functional")
proc id1 {x} {return $x}
proc id {args} {return $args}
proc myconcat {args} {join $args}

proc nonvoid {str} { string length [string trim $str] }
proc nonvoids {list} { Filter1 nonvoid $list }
proc Filter {f args} { return [Filter1 $f $args] }
proc Filter1 {f list} {
  set list2 {}
  foreach item $list {
    if [uplevel #0 $f [list $item]] {
      lappend list2 $item
    }
  }
  return $list2
}
# [Filter nonvoid foo " \t\n " " aa"]  ->  {foo { aa}}

proc Map {f args} { return [Map1 $f $args] }
proc Map1 {f list} {
  set list2 {}
  foreach item $list {
    lappend list2 [uplevel #0 $f [list $item]]
  }
  return $list2
} 



#%%%%
#
# proc1 and procj
#
#%%%%

# «proc1_procj»  (to ".proc1_procj")

proc adddollar {str} { return "\$$str" }
proc proc1_ {lastarg proc1name args1list code1} {
  proc $proc1name $args1list $code1
  set procname \
    [string range $proc1name 0 [expr [string length $proc1name]-2]]
  set nargs [llength $args1list]
  set firstargs [lrange $args1list 0 [expr $nargs-2]]
  set code "$proc1name [join [Map1 adddollar $firstargs]] $lastarg"
  proc $procname "$firstargs args" $code
}
proc proc1 {proc1name args1list code1} {
  proc1_ {$args} $proc1name $args1list $code1
}
proc procj {proc1name args1list code1} {
  proc1_ {[join $args]} $proc1name $args1list $code1
}
# So that:
#   proc1 foo1 {aaa bbb ccc} {puts hello}
# becomes:
#   proc  foo1 {aaa bbb ccc} {puts hello}
#   proc  foo  {aaa bbb args} {foo1 $aaa $bbb $args}
# and:
#   procj wee1 {ddd eee fff} {puts bye}
# becomes:
#   proc  wee1 {ddd eee fff} {puts bye}
#   proc  wee  {ddd eee args} {wee1 $ddd $eee [join $args]}
# 
# The convention is that the chopped char is always "1".

# (find-fline "~/TCL/PAGE2/linux.th")

proc void {str} { expr ![nonvoid $str] }

procj E1 {code} { uplevel #0 subst [list $code] }
procj EV1 {code} { uplevel #0 $code }
proc1 J1 {list} { join $list }



#%%%%
#
# basic html functions
#
#%%%%

# «basic_html»  (to ".basic_html")

proc <> {tag {body {}}} { return "<$tag>$body" }
proc <>n {tag {body {}}} { return "<$tag>$body\n" }
proc <></> {tag body} { return "<$tag>$body</$tag>" }
proc <></>n {tag body} { return "<$tag>$body</$tag>\n" }
proc <>n</> {tag body} { return "<$tag>$body\n</$tag>" }
proc <>n</>n {tag body} { return "<$tag>$body\n</$tag>\n" }
proc <>N</>n {tag body} { return "<$tag>\n$body</$tag>\n" }
proc <>nn</>n {tag body} { return "<$tag>\n$body\n</$tag>\n" }
proc <+></> {tag extra body} { return "<$tag $extra>$body</$tag>" }

procj HREF1 {url str} { <+></> a href=\"$url\" $str }
procj H11 {str} { <></>n h1 $str }
procj H21 {str} { <></>n h2 $str }
procj H31 {str} { <></>n h3 $str }
procj H41 {str} { <></>n h4 $str }
procj H51 {str} { <></>n h5 $str }
procj H61 {str} { <></>n h6 $str }

procj UL1 {str} { <>N</>n ul $str }
procj LI1 {str} { <>n li $str }

proc1 LIST11 {list} { UL1 [join [Map1 LI1 [nonvoids $list]] ""] }
proc1 LIST21 {list} { UL1 [join [Map1 LI1 [nonvoids $list]] ""] }
proc1 LIST31 {list} { UL1 [join [Map1 LI1 [nonvoids $list]] ""] }
proc1 HLIST11 {head list} { return [H21 $head][LIST11 $list] }
proc1 HLIST21 {head list} { return $head\n[LIST21 $list] }
proc1 HLIST31 {head list} { return $head\n[LIST31 $list] }

procj BF1 {str} { <></> strong $str }
procj IT1 {str} { <></> i $str }
procj RM1 {str} { return "</i>$str<i>" }
procj TT1 {str} { <></> code $str }
procj EM1 {str} { <></> em $str }
procj NAME1 {tag str} { <+></> a name=\"$tag\" $str }
procj COLOR1 {color str} { <+></> font color=\"$color\" $str }
procj PRE1 {str} { <></> pre $str }

procj P1 {str} { return \n\n<p>$str }

# (find-fline "$S/http/www.gnu.org/software/hurd/easy.html")
set metastr ""
proc AddMeta {tag args} {
  global metastr
  append metastr "<meta name=\"$tag\" content=\"[join $args ", "]\">\n"
}
proc AddKeywords {args} { eval AddMeta keywords $args }

procj TITLE1 {str} { <>n</>n title $str }
procj HEAD1 {str} { <>N</>n head $str }
procj BODY1 {str} { <>nn</>n body \n$str }
procj HTML1 {str} { <>N</>n html $str }

# <html>\n <head>\n <title> foo bar \n</title>\n </head>\n
#   <body>\n ... \n</body>\n </html>\n

procj TITLEDHTML1 {title body} {
  global metastr
  return [HTML1 [HEAD1 [TITLE1 $title]$metastr]\n[BODY1 $body]]
}




#%%%%
#
# encode_entities
#
#%%%%

# «encode_entities»  (to ".encode_entities")

# splitter - split in pattern/nonpattern chunks.
# This is used by encode_entities.
#
proc splitter0 {str p1p2} {
  foreach {p1 p2} $p1p2 {}
  return [list [string range $str 0 [expr $p1-1]] \
      [string range $str $p1 $p2] \
      [string range $str [expr $p2+1] end]]
}
proc splitter {pat str} {
  set rest $str
  while {[regexp -indices $pat $rest {} range]} {
    foreach {prematch match rest} [splitter0 $rest $range] {}
    lappend pieces $prematch $match
  }
  lappend pieces $rest
  return $pieces
}

# encode_entities: "&" -> "&amp;", etc
#
for {set x 128} {$x<256} {incr x} {
  set Entname([format "%c" $x]) [format "%c" $x]
}
# puts $Entname(ˆ) -> ˆ
foreach {char entname} {
  Æ AElig  Á Aacute  Acirc  À Agrave Å Aring  à Atilde Ä Auml  
  Ç Ccedil É Eacute Ê Ecirc  È Egrave Ë Euml   Í Iacute Ï Iuml  
  Ó Oacute Ô Ocirc  Ò Ograve Õ Otilde Ö Ouml   Ú Uacute Û Ucirc 
  Ù Ugrave Ü Uuml   á aacute â acirc  æ aelig  à agrave å aring 
  ã atilde ä auml   ç ccedil é eacute ê ecirc  è egrave ë euml  
  í iacute î icirc  ì igrave ï iuml   ó oacute ô ocirc  ò ograve
  õ otilde ö ouml   ß szlig  ú uacute û ucirc  ù ugrave ü uuml  
  ª ordf   « laquo  ° deg    º ordm   » raquo
  & amp  > gt  < lt  \" quot } {
    set Entname($char) "&$entname;"
  }
proc encode_entities {str} {
  global Entname
  # set spl [splitter "(\[\"<>&\200-\377\]+)" $str]
  set spl [splitter "(\[<>&\200-\377\]+)" $str]
  foreach {straight queer} $spl {
    append encoded $straight
    set equeer ""
    foreach c [split $queer {}] {
      append equeer $Entname($c)
    }
    append encoded $equeer
  }
  return $encoded
}

procj Q1 {str} { encode_entities $str }
#proc Q {args} { Q1 [J $args] }




#%%%%
#
# local/remote modes
#
#%%%%

# «local_remote_modes»  (to ".local_remote_modes")

# Local/remote modes
# The default is local.
#
set islocalv 0
proc islocal {args} { global islocalv; eval set islocalv $args }
proc IFLR {yescode {nocode {}}} {
  if [islocal] {
    EV1 $yescode
  } else {
    EV1 $nocode
  }
}
proc1 IFL1 {code} { IFLR $code }
proc1 IFR1 {code} { IFLR {} $code }




#%%%%
#
# Boolean environment variables
#
#%%%%

# «boolean_env_vars»  (to ".boolean_env_vars")
# (find-es "tcl" "environment")
#
proc env {vname {default {}}} {
  global env
  if {[info exists env($vname)]} {
    return $env($vname)
  } else {
    return $default
    # TO DO: make it scream if called without default and vname not found
  }
}
proc getboolenv {vname} { env $vname 0 }


# If DOLOCAL is 1,
# we enter local mode.
#
if [getboolenv DOLOCAL] {
  islocal 1
}




#%%%%
#
# Local/remote urls
#
#%%%%

# «local_remote_urls»  (to ".local_remote_urls")
#
set snarfprefix [env S /snarf]

proc tosnarf {url} {
  global snarfprefix
  if [regexp "^((http|ftp|file)://)(.*)$" $url {} {} proto rest] {
    set url $snarfprefix/$proto/$rest
  }
  return $url
}
proc addindexhtml {url} {
  if [regexp "^/snarf/http/.*/$" $url] {
    if [file exists ${url}index.html] {
      set url ${url}index.html
    }
  }
  return $url
}
proc ungz {url} {
  if [regexp {^(/.*\.(ps|dvi))\.(z|gz|Z)} $url -> ungzurl] {
    if [file exists $ungzurl] {
      return $ungzurl
    }
  }
  return $url
}
proc tosnarfindex {url} { ungz [addindexhtml [tosnarf $url]] }
proc isrmturl {url} { regexp "^((http|ftp|file)://)(.*)$" $url }
proc islocalurl {url} { expr ![isrmturl $url] }

proc lurl {url} {
  if {[islocal] && [isrmturl $url]} {
    tosnarfindex $url
  } else {
    return $url
  }
}


procj LRHREF1 {url text} {
  if {$text==""} {set text [Q1 $url]}
  if {[islocal] && [isrmturl $url]} {
    set url2 [tosnarfindex $url]
    return "[HREF1 $url2 $text] ([HREF $url rmt])"
  } else {
    HREF1 $url $text
  }
}
procj LHREF1 {url text} {
  if {$text==""} {set text [Q1 $url]}
  if {[islocal] && [isrmturl $url]} {
    set url2 [tosnarfindex $url]
    HREF1 $url2 $text
  } else {
    HREF1 $url $text
  }
}


# L/L1 are the most usual ways to write links.
# They are sentitive to "islocal" and to Lr-mode;
# see below.
#
set metaL1 LHREF1
procj L1 {url text} {
  global metaL1
  $metaL1 $url $text
}
procj LR1 {url text} {
  LRHREF1 $url $text
}



#%%%%
#
# Modifiers: Rmt, Lr.
# 
#%%%%

# «LR_modifiers»  (to ".LR_modifiers")

# Rmt evals its code as if we were in remote mode.
# Lr evals its code in LR mode, i.e., each snarfable link gets a local
# version and a remote version.
# The code they get is evaluated at top level, not E'ed; it must start
# with the name of a command. For example:
#
# Rmt L http://foo Foo Bar
# Rmt1 {L http://foo Foo Bar}
# Rmt1 {concat [L http://foo Foo Bar], a f.b. page.} 

procj Rmt1 {code} {
  set oldislocal [islocal]
  islocal 0
  set retstr [uplevel #0 $code]
  islocal $oldislocal
  return $retstr
}

procj Lr1 {code} {
  global metaL1
  set oldmetaL1 $metaL1
  set metaL1 LRHREF1
  set retstr [uplevel #0 $code]
  set metaL1 $oldmetaL1
  return $retstr
}



#%%%%
#
# File I/O
#
#%%%%

# «file_IO»  (to ".file_IO")


proc readfile {fname} {
  set channel [open $fname r]; set bigstr [read $channel]; close $channel
  return $bigstr
}
proc writefile {fname bigstr} {
  set channel [open $fname w]; puts -nonewline $channel $bigstr; close $channel
}
set outfile "-"
proc outputs {bigstr} {
  global outfile
  if {$outfile=="-"} {
    puts -nonewline $bigstr
  } else {
    writefile $outfile $bigstr
  }
}



#%%%%
#
# Relative links 
#
#%%%%

# «relative_links»  (to ".relative_links")

proc relativepathto {to} {
  global outfile
  set from $outfile
  while {[regexp {([^/]+)/(.*)} $from {} p1from restfrom] &&
         [regexp {([^/]+)/(.*)} $to {} p1to restto] &&
         $p1from==$p1to} {
       set from $restfrom
       set to $restto
     }
  while {[regexp {([^/]+)/(.*)} $from {} p1from restfrom]} {
    set from $restfrom
    set to "../$to"
  }
  return $to
}



#%%%%
#
# Some extra utilities, in no particular order.
#
#%%%%

# «extra_utils»  (to ".extra_utils")

proc1 exclude1 {all no} {
  set rest {}
  foreach item $all {
    if {[lsearch $no $item]==-1} {
      lappend rest $item
    }
  }
  return $rest
}
# Almost the same:
proc1 without1 {no all} {
  exclude1 $all $no
}




#%%%%
#
# Functions for processing templates (for the Hurd pages)
#
#%%%%

# «templates»  (to ".templates")
# (find-es "hurd" "fsmunoz-template")

# split_by_guills replaces the slow regexp below:
# regexp {^(.*)«([^«»]*)»(.*)$} $bigstr -> before between after

proc split_by_guills {str vbefore vbetween vafter} {
  set p2 [string first » $str]
  if {$p2<0} { return 0 }
  set p1 [string last « [string range $str 0 $p2]]
  if {$p1<0} { error "too many closing guillemots" }
  upvar $vbefore  before
  upvar $vbetween between
  upvar $vafter   after
  set before  [string range $str 0 [expr $p1-1]]
  set between [string range $str [expr $p1+1] [expr $p2-1]]
  set after   [string range $str [expr $p2+1] end]
  return 1
}

proc process_template {bigstr} {
  while {[split_by_guills $bigstr before between after]} {
      puts !!!
    if {![regexp {^([^*]*)*(.*)$} $between -> tclcode pairs]} {
      error "No Tcl code"
    }
    parse_pairs $pairs
      puts $tclcode
    uplevel #0 $tclcode
    set bigstr "$before œœœ $after"
  }
  return $bigstr
}

proc parse_pairs {str} {
  global lcapts rcapts
  set lcapts {}
  set rcapts {}
  foreach pair [split $str "*"] {
    if {[regexp {^(([^]*))?([^]*)$} $pair -> _ lcapt rcapt]} {
      lappend lcapts $lcapt
      lappend rcapts $rcapt
    } else {
      error "Too many triangles"
    }
  }
}

proc captdef {procf func arglist body} {
  global lcapts rcapts
  set precode {}
  foreach lcapt $lcapts rcapt $rcapts {
    if {$lcapt!="" && [lsearch $arglist $lcapt]==-1} {
      append precode "[list set $lcapt $rcapt]\n"
    }
  }
  # puts     "$procf [list $func] [list $arglist] [list $precode$body]"
  uplevel #0 "$procf [list $func] [list $arglist] [list $precode$body]"
}









# Note that this file (Htmllib.tcl) is just a library.
# The top-level stuff is at:

# (find-fline "~/TH/Generate")

# Older notes:
# (find-fline "~/TCL/localth")
# (find-fline "~/TCL/remoteth")
# (find-fline "~/TCL/e2html")
# (find-fline "~/TCL/generate")

# Some of them may be symlinks. Check:

# (find-fline "~/TCL/")


#  Local Variables:
#  coding:               no-conversion
#  ee-anchor-format:     "«%s»"
#  ee-charset-indicator: "Ñ"
#  End: