#!/usr/bin/tclsh

# https://github.com/HexFiend/HexFiend/blob/master/templates/Reference.md
# https://github.com/HexFiend/HexFiend/blob/master/templates/Tutorial.md

package require cmdline

set __f {}
set __fs 0
set __fpos 0

proc __globals {args} {
  foreach pat $args {
    foreach sym [info globals $pat] {
      uplevel 1 [list global $sym]
    }
  }
}

proc __args {opts {vars ""}} {
  upvar 1 args upargs
  foreach {name val} [::cmdline::getoptions upargs $opts] {
    uplevel 1 [list set $name $val]
  }
  if {$vars ne "" } { uplevel 1 "set args \[lassign \$args $vars\]" }
}

proc __unpack {sel sz} {
  global __f
  if {![binary scan [read $__f $sz] $sel ret]} {
    error "Reading beyond EOF"
  }
  return $ret
}
proc __unpack_entry {sel sz args} {
  __args {{hex}} name
  set val [__unpack $sel $sz]
  if {$hex} { set val [format "0x%X" $val] }
  if {$name ne ""} { entry $name $val $sz [expr {[pos] - $sz}] }
  return $val
}

proc little_endian {} {}
proc big_endian {} { error Unimplemented }
proc requires {offset pattern} {}
proc hf_min_version_required {ver} {}

proc     uint64 {args} { __unpack_entry wu 8 {*}$args }
proc      int64 {args} { __unpack_entry w  8 {*}$args }
proc     uint32 {args} { __unpack_entry iu 4 {*}$args }
proc      int32 {args} { __unpack_entry i  4 {*}$args }
proc     uint24 {args} { error Unimplemented }
proc     uint16 {args} { __unpack_entry su 2 {*}$args }
proc      int16 {args} { __unpack_entry s  2 {*}$args }
proc      uint8 {args} { __unpack_entry cu 1 {*}$args }
proc       int8 {args} { __unpack_entry c  1 {*}$args }
proc      float {args} { error Unimplemented }
proc     double {args} { error Unimplemented }
proc       uuid {args} { error Unimplemented }
proc    macdate {args} { error Unimplemented }
proc    fatdate {args} { error Unimplemented }
proc    fattime {args} { error Unimplemented }
proc unixtime32 {args} { error Unimplemented }
proc unixtime64 {args} { error Unimplemented }

proc  uint8_bits {args} { error Unimplemented }
proc uint16_bits {args} { error Unimplemented }
proc uint32_bits {args} { error Unimplemented }
proc uint64_bits {args} { error Unimplemented }

# TODO: support size 'eof'
proc bytes {size {name ""}} { global __f; read $__f $size; set val "<$size bytes>"; if {$name ne ""} { entry $name $val $size [expr {[pos] - $size}] }; return $val }
proc hex {size {name ""}} { error Unimplemented }
proc ascii {size {name ""}} { global __f; set val [read $__f $size]; if {$name ne ""} { entry $name $val $size [expr {[pos] - $size}] }; return $val }
proc utf16 {size {name ""}} { error Unimplemented }
proc str {size enc {name ""}} {
  # TODO: apply encoding
  ascii $size
}
proc cstr {enc {name ""}} {
  # TODO: apply encoding
  global __f
  lassign [list [pos] "" 1] pos0 val ch
  while {$ch ne "\x000"} {
    set ch [read $__f 1]
    append val $ch
  }
  if {$name ne ""} { entry $name $val [expr {[pos] - $pos0}] $pos0 }
  return $val
}

proc __safeStr {str} {
  #subst [regsub -all {[\x000-\x01f]} [regsub -all {[$\[\]\\]} $str {\\&}] {[format "\\\\x%02X" [scan "\\&" %c]]}]
  #regsub -all {[\x000-\x01f]} [regsub -all {[$\[\]\\]} $str {\\&}] "·"
  regsub -all {[\x000-\x01f\x080-\xfff]} $str "·"
  #regsub -all {[\x000-\x01f]} $str "·"
}

set __indentlevel 0
set __indentstr ""
proc __ii {incr} {
  global __indentlevel; global __indentstr
  incr __indentlevel $incr
  set __indentstr [string repeat "  " $__indentlevel]
}
proc __i {} { global __indentstr; return $__indentstr }
set __output ""
set __secname ""
set __secval ""
proc say {str} {
  global __indentstr; global __indentlevel; global __output
  #puts "$__indentstr$str"
  if {$__indentlevel} {
    append __output $__indentstr $str "\n"
  } else {
    # Use catch to eliminate complaints about broken pipe
    if {[catch {puts $str}]} { exit }
  }
}
proc entry {name val args} { say "$name = [__safeStr $val] ($args)"; return $val }
proc section {args} {
  globals __output __sec* __indent*
  __args {{collapsed}}
  if {[llength $args] != 2} { error "section [-collapsed] name body" }
  lassign $args name body
  set pos0 [pos]
  set tmp_output $__output;   set __output ""
  set tmp_secname $__secname; set __secname $name
  set tmp_secval $__secval;   set __secval ""
  __ii 2
  uplevel 1 $body
  __ii -2
  set len [expr {[pos] - $pos0}]
  if {$__secval ne ""} { set __secval " # $__secval" }
  set __output "$tmp_output$__indentstr$__secname {$__secval ($len $pos0)\n$__output$__indentstr}\n"
  set __secname $tmp_secname
  set __secval $tmp_secval
  if {!$__indentlevel} {
    puts -nonewline $__output
    set __output ""
    set __secname ""
    set __secval ""
  }
}
proc endsection {args} { error Unimplemented }
proc sectionname {name} { global __secname; set __secname $name }
proc sectionvalue {val} { global __secval; set __secval [__safeStr $val] }

proc goto {pos} { global __f; seek $__f $pos start }
proc move {pos} { global __f; seek $__f $pos current }
proc pos {} { global __f; tell $__f }
proc len {} { global __fs; return $__fs }
proc end {} { global __fs; expr {[pos] >= $__fs} }

#proc __scriptrelpath {{path ""}} { file join [file dirname [ file normalize [ info script ] ] ] $path }
proc __scriptrelpath {{path ""}} { file join $::env(HOME) "Library/Application Support/com.ridiculousfish.HexFiend/Templates" $path }

#proc include {args} { source {*}$args }
proc include {fname} {
  set fh [open [__scriptrelpath $fname] r]
  set contents [read $fh]
  close $fh
  uplevel 1 $contents
}

proc __find_template_path {template} {
  set templatepath [__scriptrelpath $template]
  if {[file isfile $templatepath]} { return $templatepath }
  if {[file isfile "$templatepath.tcl"]} { return "$templatepath.tcl" }
  set templates [glob -nocomplain -type f -directory [__scriptrelpath] "$template.tcl" "*/$template.tcl"]
  if {[llength $templates] == 1} { return [lindex $templates 0] }
  if {[llength $templates] > 1} {
    puts "Ambiguous template name: $template"
    foreach f $templates {
      set name [file rootname]
      puts "[file join [lindex [file split $name] end-1 end]]"
    }
    exit 1
  }
  puts "Can't find template: $template. Available templates:"
  foreach f [glob -nocomplain -type f -directory [__scriptrelpath] *.tcl */*.tcl] {
    puts "  [file rootname [file tail $f]]"
  }
  exit 1
}

set argv [lassign $argv template]

if {$template eq "" || [llength $argv] < 1} {
  puts "Usage: hexparse {TEMPLATE} \[... files\]"
  exit
}
set template [__find_template_path $template]

foreach fname $argv {
  puts "--- File: $fname ([file size $fname] bytes)"
  set __fs [file size $fname]
  set __f [open $fname r]
  fconfigure $__f -buffering full -buffersize 1048576 -encoding binary -translation binary
  #source WT/WT.tcl
  source $template
  close $__f
}

