### 
### OBEX protocol folder-listing xml-parser
### 
### <?xml version="1.0"?>
### <!DOCTYPE folder-listing SYSTEM "obex-folder-listing.dtd">
### <folder-listing version="1.0">
###    <file name="demotimeSheet.jad" size="301" 
###            modified="20030214T235606" user-perm="RWD" group-perm="R" />
###    <file name="demotimeSheet.jar" size="23949" 
###            modified="20030214T235614" user-perm="RWD" group-perm="R" />
###    <folder name="storage" modified="20030214T235644" 
###            user-perm="RWD" group-perm="W" />
### </folder-listing>
###
### History:
###   20031107: config params obexexe and obexdev removed - a wrapper
###             shell $OBEXDIR/obexftp.sh will be used in future - ger
###   20040504: parser reworked - newlines become ignored - ger
###   20040712: patch for Nokia 6230, provided by Michael Wikberg -
###             thank you Michael! - ger
###   20050117: optional utf-8 encoding implemented - ger
###   20050205: optional html quoting implemented, list may be extended - ger
###   20050208: patch from Andreas Böhler for Ericsson T630/K700i for 
###             correct html-quoting included - thank you Andreas! - ger
###   20050610: optional add_lslash for Siemens C65V (also M50), see function 
###             obexftp, command "ls" - thanks to Thomas Sefzick - ger
###   20050706: local config values moved to central config 
###             etc/obextool.cfg.
###   20060115: <folder-listing... tag changed to work with Motorola V500,
###             it uses "<folder-listing>" - thanks to M.Fedotov - ger
###   20081206: obexfileio changed to work with spaces in obexftp path, 
###             thanks to S.Huntley.
###             Some old Alcatel's don't line root slashes - set new config
###             parameter config,root_name (thanks to David Kühling) - ger

package provide obexfile 0.8

namespace eval ObexFile {
  ### encoding param
  variable encoding [getObexCfg config encoding]
  ### if html quoting is wanted... 
  variable quote_map [getObexCfg config quote_map]
  ### Temporary file name prefix
  variable tmp_prefix [getObexCfg temp prefix]
  ### Siemens S65V requires the trailing slash on obexftp ls
  variable add_lslash [getObexCfg config add_lslash]
  ### Nokia 6670 requires the trailing slash on all directory names
  variable dir_slash [getObexCfg config dir_slash]
  ### Ommit root directory name on some old Alcatel's
  variable root_slash [getObexCfg config root_slash]
  ### Do not chdir for file sommands
  variable dont_chdir [getObexCfg config dont_chdir]
  ### date format
  variable date_format [getObexCfg file datefmt]
 
  variable array TAG
  set TAG(end) "/>"

  ### siemens M50   <?xml version="1.0"?>
  ### ericsson T610 <?xml version="1.0" encoding="UTF-8"?>
  set TAG(XML_identifier) \
      "<?xml version=\"1.0\"" 

  ### siemens M50 <!DOCTYPE folder-listing SYSTEM "obex-folder-listing.dtd">
  ### nokia 6230  <!DOCTYPE folder-listing SYSTEM "obex-folder-listing.dtd"
  ###              [ <!ATTLIST folder mem-type CDATA #IMPLIED> ]>
  set TAG(DTD_identifier) \
      "<!DOCTYPE folder-listing SYSTEM \"obex-folder-listing.dtd\""

# set TAG(folder-listbeg) \
#     "<folder-listing version=\"1.0\">"
  ### motorola V500:   <folder-listing>
	### all other known: <folder-listing version="1.0">
  set TAG(folder-listbeg) \
      "<folder-listing"
  set TAG(folder-listend) \
      "</folder-listing>"

  ### nokia 6230 specific <parent-folder />
  ###  ... does not appear in mmc-subdirectory ?!?!
  set TAG(parent-folder) \
      "<parent-folder "

  set TAG(file_begin) "<file"
  set TAG(file_end) $TAG(end)
  set TAG(folder_begin) "<folder"
  set TAG(folder_end) $TAG(end)

  variable separator [list " \t\n"]

  variable file_date 

proc format_date {idate} {
  variable date_format
# global ObexConfig
# set date_format $ObexConfig(file,datefmt)
  if {![string compare $idate ""]} {return $idate}

  set date_res ""
  set sl [string length $date_format]
  for {set i 0} {$i<$sl} {incr i} {
    set fmt_c [string index $date_format $i]
    set ufmt [string toupper $fmt_c]
    # 012345678901234
    # 20090102T104536
    switch -- $ufmt {
      Y { set pattern [string range $idate  0  3] ; ### 4 digit year    }
      Z { set pattern [string range $idate  2  3] ; ### 2 digit year    }
      M { set pattern [string range $idate  4  5] ; ### 2 digit month   }
      D { set pattern [string range $idate  6  7] ; ### 2 digit day     }
      H { set pattern [string range $idate  9 10] ; ### 2 digit hour    }
      N { set pattern [string range $idate 11 12] ; ### 2 digit minute  }
      S { set pattern [string range $idate 13 14] ; ### 2 digit seconds }
      default { set pattern $fmt_c }
    }
    if {[lsearch -exact [list z m d h n s] $fmt_c] != -1} {
      append date_res [expr {1 * $pattern}] ; ### format to integer
    } else {
      append date_res $pattern
    }
  }
  return $date_res
}
proc extension { path } {
  set ext [file extension $path]
  if [string length $ext] {
    return [string range $ext 1 end]
  } else {
    return $ext
  }
}
proc is_folder { fileid } {
}
proc get_filetype { stoken name } {
  variable TAG
  if {![string compare $stoken $TAG(folder_begin)]} {
    return folder
  } 
  return [string tolower [extension $name]]
}
proc name_sep { ch } {
  if {[string is alpha $ch]} {return 1}
  if {![string compare $ch "-"]} {return 1}
  return 0
}
proc att_value_list { arr fline } {
# debug_out "att_value_list $arr $fline"
  upvar $arr key
  set sl [string length $fline]
###
### extract named token (vname)
###
  while {$sl > 0} {
    set i 0
    set vname ""
    set ch1 [string index $fline $i]
    while {[name_sep $ch1]} {
      append vname $ch1
      set ch1 [string index $fline [incr i]]
# debug_out "ch1='$ch1' vname=$vname"
      if { $i >= $sl } break;
    }
    set fline [string range $fline [incr i] end]
    set fline [string trim $fline]
# debug_out "fline=$fline"
###
### only keyword, no value follows (token=value)?
###
# debug_out "ch1='$ch1'"
    set value ""
    if { $ch1 ne "=" } {
      set value ""
      set key($vname) $value 
      set fline [string trimleft $fline]
      set sl [string length $fline]
      continue
    }
###
### value without quotes?
###
    set fline [string trim $fline]
    set ch1 [string index $fline [set i 0]]
# debug_out "$ch1 ne '\"'"
    if { $ch1 ne "\"" } {
      set value [lindex [split $fline] 0]
      set $fline [string range $fline [string length $value] end]
      set key($vname) $value 
      set fline [string trimleft $fline]
      set sl [string length $fline]
      continue
    }
###
### value with quotes (may include white spaces...)
###
    set sl [string length $fline]
    set ch1 [string index $fline [set i 1]]
# debug_out "ch1 eq '$ch1'"
    while { $ch1 ne "\"" } {
      append value $ch1
      set ch1 [string index $fline [incr i]]
# debug_out "ch1='$ch1' $ch1 ne \"\"\" value=$value"
      if { $i >= $sl } break;
    }
    set fline [string range $fline $i end]
    set fline [string trimleft $fline]
    set sl [string length $fline]
    set key($vname) $value 
# debug_out "key($vname) ne \"$value\""
  }
}

proc save_append { vname } {
  upvar $vname key
  if [info exists key] {
    return $key
  } else { 
    return "" 
  }
}

proc read_entry { stoken fline } {
# debug_out "read_entry $stoken $fline"
  variable file_date
  set out_line {}
  set sidx [string length $stoken]
  set eidx [expr [string length $fline]-3]
  set fline [string range $fline $sidx $eidx]

  att_value_list dir_entry [string trim $fline]
  if {[info exists dir_entry(modified)]} {
    set file_date($dir_entry(name)) $dir_entry(modified)
  } else {
    set file_date($dir_entry(name)) ""
  }
  
  lappend out_line $dir_entry(name)
  lappend out_line [get_filetype $stoken $dir_entry(name)]
  lappend out_line [save_append dir_entry(size)]
  lappend out_line [format_date [save_append dir_entry(modified)]]
  lappend out_line [save_append dir_entry(user-perm)]
  lappend out_line [save_append dir_entry(group-perm)]

  return $out_line
}

proc obex_chkarg { cmd reason check } {
  debug_out "obex_chkarg $cmd $reason $check" 2
  if ![string compare $check ""] {
    internal_error "called obexftp '$cmd' without '$reason'"
  }
}

proc get_filename { fn } {
  variable encoding
  variable quote_map
  if {$encoding ne ""} {
    set fn [encoding convertfrom $encoding $fn]
  }
  if {$quote_map ne ""} {
    set fn [string map $quote_map $fn]
  }
  return $fn
}

proc obexfileio { params } {
  variable encoding
  variable quote_map

  set obexecute [getObexCfg obexftp command]
  set ret_val {}

  set pipecmd "|$obexecute"
  foreach p $params {lappend pipecmd $p}
debug_var pipecmd 3

  set infile [open $pipecmd "r"]
  fconfigure $infile -translation binary

### single file read is done
  set lines [read -nonewline $infile]
  catch {close $infile}
# debug_var lines 3 

### part, if no XML output (eg. --info command)
  if {[string first "<" $lines]<0} {
    foreach line [split $lines "\n"] {lappend ret_val [string trim $line]}
    return $ret_val
  } 

### it is XML output... 
  while {[set start [string first "<" $lines]]>=0} {
    set endst [string first ">" $lines]
    set nextl [string range $lines $start $endst]
    if {$encoding ne ""} {
      set nextl [encoding convertfrom $encoding $nextl]
    } 
    if {$quote_map ne ""} {
      set nextl [string map $quote_map $nextl]
    }
    lappend ret_val [string trim $nextl]
    set lines [string range $lines [incr endst] end]
  }

  #  debug_out "obexfileio -> $ret_val" 4 
  return $ret_val
}

proc obexftp { cmd args } {
  global OBEXDIR 
  variable dont_chdir
  variable root_slash
  variable add_lslash
  variable dir_slash
debug_out "obexftp $cmd $args" 3

  set chdir [getObexCfg fileopt chdir]

  set fn1 [lindex $args 0]
  set fn2 [lindex $args 1]
  set fn3 [lindex $args 2]
  set ret_val {}

  case $cmd {
    ls {
      set cmd [getObexCfg fileopt list]
      obex_chkarg $cmd path $fn1
      if {$dir_slash} {set add_lslash ""}
      ### We add a slash to file name (Thomas Sefzick)

      set nam [get_filename [file tail $fn1]]$add_lslash
      regexp .$ $fn1 fn2
       
      if {$fn2 eq "/"} {
        if {$dir_slash} {
          set dir $fn1
          set nam ""
        } elseif {$add_lslash eq "/"} {
          set dir "/"
          set nam ""
        } elseif {!$root_slash} {
          set dir ""
          set nam ""
        } else {
          set dir [get_filename [file dirname $fn1]]
        }
      } else {
        set dir [get_filename [file dirname $fn1]]
      }
      if {$nam eq "" && $dir eq ""} {
        set command "$cmd"
      } elseif {$nam eq ""} {
        set command "$chdir {$dir} $cmd"
      } elseif {$dir eq ""} {
        set command "$cmd {$nam}"
      } else {
        set command "$chdir {$dir} $cmd {$nam}"
      }
    }
    gf { 
      set cmd [getObexCfg fileopt get]
      obex_chkarg $cmd pathname $fn1
      if {$dont_chdir} {
        set fn1 [get_filename $fn1]
        set command "$cmd {$fn1}"
      } else {
        set dir [get_filename [file dirname $fn1]]
        set nam [get_filename [file tail $fn1]]
        set command "$chdir {$dir} $cmd {$nam}"
      }
    }
    pf { 
      set cmd [getObexCfg fileopt put]
      obex_chkarg $cmd sourcename $fn1 
      obex_chkarg $cmd destination $fn2
      set fn1 [get_filename $fn1]
      set fn2 [get_filename $fn2]
      set command "$chdir {$fn2} $cmd {$fn1}" 
    }
    mv { 
      set cmd [getObexCfg fileopt move]
      obex_chkarg $cmd sourcename $fn1
      obex_chkarg $cmd destination $fn2
      set fn1 [get_filename $fn1]
      set fn2 [get_filename $fn2]
      set command "$cmd {$fn1} {$fn2}" 
    }
    rm { 
      set cmd [getObexCfg fileopt delete]
      obex_chkarg $cmd pathname $fn1
      if {$dont_chdir} {
        set fn1 [get_filename $fn1]
        set command "$cmd {$fn1}"
      } else {
        set dir [get_filename [file dirname $fn1]]
        set nam [get_filename [file tail $fn1]]
        set command "$chdir {$dir} $cmd {$nam}"
      }
    }
    md { 
      set cmd [getObexCfg fileopt mkdir]
      obex_chkarg $cmd dirname $fn1
      if {$dont_chdir} {
        set fn1 [get_filename $fn1]
        set command "$cmd {$fn1}"
      } else {
        set dir [get_filename [file dirname $fn1]]
        set nam [get_filename [file tail $fn1]]
        set command "$chdir {$dir} $cmd {$nam}"
      }
    }
    st { 
      ### This only work for Siemens :-(
      set cmd [getObexCfg fileopt info]
      obex_chkarg $cmd status "dummy"
      set command "$cmd" 
    }
    ca { 
      ### Rerieve device capabilties
      set cmd [getObexCfg fileopt capability]
      obex_chkarg $cmd status "dummy"
      set command "$cmd" 
    }
    ve { 
      ### New option to retrieve obexftp version
      set cmd [getObexCfg fileopt version]
      obex_chkarg $cmd version "dummy"
      set command "$cmd" 
    }
    default {
      internal_error "Unknown command: '$cmd' $args"
    }
  }

  return [obexfileio $command]
}

proc list_dir { path } {
debug_out "list_dir $path" 4 
  variable separator 
  variable file_date 
  variable TAG 
  set ret_val ""
  array unset file_date
  array set file_date {}

  set obex_dir [obexftp ls $path]

  set state begin
  foreach line $obex_dir {
# debug_out "line=$line" 4
    switch -- $state {
      begin {
        if {-1!=[string first $TAG(XML_identifier) $line]} {set state header}
      }
      header {
        if {-1!=[string first $TAG(DTD_identifier) $line]} {set state listing}
      }
      listing {
        if {-1!=[string first $TAG(folder-listbeg) $line]} {set state entities}
      }  
      end_listing {
        if {-1!=[string first $TAG(folder-listend) $line]} {set state end_data}
      }
      entities {
        set stoken [lindex [split $line $separator] 0]
        if {![string compare $stoken $TAG(folder_begin)]} {
          lappend ret_val [read_entry $stoken $line]
        } elseif {![string compare $stoken $TAG(file_begin)]} {
          lappend ret_val [read_entry $stoken $line] 
#### TAG(parent-folder) is used on Nokia 6230-phone ... do nozzin ...
#### patch from Michael Wikberg - 20040713
        } elseif {![string match $TAG(parent-folder)* $stoken]} {
        } else {
          set state end_listing
        }
      }
      end_data {
        debug_out "line after listing ignored ignored..." 3
      }
      default {
        debug_out "ignorin line: $line" 2
      }
    }
  }
	debug_var ret_val 9
  return $ret_val
}

proc get_tmpfile {ext} {
  variable tmp_prefix
	set idx 0
  set local "$tmp_prefix[format %05d [expr int(rand()*10000)]]$idx.$ext"
  while {[file exists $local]} {
    debug_out "temp file name collision '$local'"
    if {[incr idx]>$max_tries} {
      internal_error [get_text "Unable to create temporary file '$local'!"]
    } 
    set local "$tmp_prefix[format %05d [expr int(rand()*10000)]]$idx.$ext"
  }
	return $local
}

proc save_rename { from to } {
  set res [catch {file rename $from $to} err]
	if {$res} {
	  set msg [get_text "File rename error!\nError: %s"]
	  warning [format $msg $err]
		return $res
	}
	if {![file exists $to]} {
	  set msg [get_text "File rename error - no destination '%s'!"]
	  warning [format $msg $to]
		return -1
	}
	if {[file exists $from]} {
	  set msg [get_text "File rename error - source '%s' still exists!"]
	  warning [format $msg $from]
		return -2
	}
	return 0
}
proc try_rename { name } {
  set idx 0
	set renamed ""
	set max_tries 15
  set fn $name.$idx
  while {[file exists $fn]} { 
    if {[incr idx]>$max_tries} {
      internal_error [get_text "Unable to create temporary file for '$name'!"]
    } 
    set fn $name.$idx
    debug_out "$name.$idx -> [file exists $fn]" 6
  }
  if {[catch {file rename $name $fn} err]} {
	  set msg [get_text "Rename to '%s' failed - error:\n%s\nRetrying..."]
	  warning [format $msg $fn $err]
  } else {
    set renamed $fn
    debug_out "File '$name' temporarily renamed to '$renamed'" 
	}
	return $renamed
}

proc read_file_tmp { path } {
  debug_out "read_file_tmp $path" 3

  set idx 0
  set renamed ""
	set max_tries 15
  set ext [extension $path]
  set name [file tail $path]
  set curr_dir [pwd]

  while {[file exists $name]} {
	  set renamed [try_rename $name]
  }
  
	set local [get_tmpfile $ext]
  set emesg \
	  [get_text "File '%s' renamed to '%s' - please rename it back manually."]

  obexftp gf $path 
  if ![file exists $name] {
    set msg "Unable to create file '%s' in current folder %s!"
    warning [format $msg $name $curr_dir]
    return {}
  }

debug_out "renaming '$name' to '$local'" 3
  if [save_rename $name $local] {
	  warning [format $emesg $name $renamed]
	  return ""
	}

  if {![string_empty $renamed]} {
    if [save_rename $renamed $name] {
	    warning [format $emesg $name $renamed]
	  }
    debug_out "File renamed back to '$name'" 3
  }

  return $local
}

proc write_file_tmp { local path } {
  debug_out "write_file_tmp $local $path" 3
	set max_tries 15
  set renamed ""

  set name [file tail $path]
  set dir_name [file dirname $path]
  set curr_dir [pwd]
  
  while {[file exists $name]} {
	  set renamed [try_rename $name]
  }

  set emesg \
	  [get_text "File '%s' renamed to '%s' - please rename it back manually."]
  if [save_rename $local $name] {
		warning [format $emsg $name $renamed]
	  return 
  }

  debug_out "File '$local' renamed to '$name'" 4
  if ![file exists $name] {
    if ![string_empty $renamed] {
      if [save_rename $renamed $name] { 
		    warning [format $emsg $name $renamed]
			  return 
		  }
      debug_out "File '$renamed' renamed back to '$name'" 3
    }
    set msg "Unable to create file '%s' in current folder %s!"
    warning [format $msg $path $curr_dir]
    return 
  }

  obexftp pf $name $dir_name
  file delete $name 
  debug_out "Local file '$name' deleted" 3

  if {![string_empty $renamed]} {
    save_rename $renamed $name
    debug_out "File renamed back to '$name'" 3
  }

}

###
### very important "dir/file/any exists" function
### main problem is the different behaviour of the 
### obex devices and the different "representation"
### of the file entities (with(out) size, with(out)
### permissions, with(out) file date ...
###
proc path_exists { which path } {
debug_out "path_exists $which $path" 3

###
### check 1 complete path name
###
  set nam [file tail $path]
	
  set fnd [list_dir $path]
#  debug_var fnd 9
### # if [llength $fnd] {return 1}
  foreach fil $fnd {
    set fnam [lindex $fil 0]
    set ftyp [lindex $fil 1]
debug_out "$ftyp $fnam $fil" 9
    set isfile ![string equal "folder" $ftyp]
    set nameeq [string equal $nam $fnam]
debug_out "$fnam - $ftyp" 9
debug_out "$isfile && $nameeq" 9
    switch $which {
      any  { if {[expr $nameeq            ]} {return 1} }
      dir  { if {[expr $nameeq && !$isfile]} {return 1} }
      file { if {[expr $nameeq &&  $isfile]} {return 1} }
      default {
        internal_error "path_exists: invalid path type '$which'!"
      }
    }
  }
###
### check 2 file/folder name in upper level folder
###
  set path [file dirname $path]
  set fnd [list_dir $path]
# debug_var fnd 9
#### if [llength $fnd] {return 1}
  foreach fil $fnd {
    set fnam [lindex $fil 0]
    set ftyp [lindex $fil 1]
    set isfile ![string equal "folder" $ftyp]
    set nameeq [string equal $nam $fnam]
debug_out "$fnam - $ftyp" 3
debug_out "$isfile && $nameeq" 3
    switch $which {
      any  { if {[expr $nameeq            ]} {return 1} }
      dir  { if {[expr $nameeq && !$isfile]} {return 1} }
      file { if {[expr $nameeq &&  $isfile]} {return 1} }
      default {
        internal_error "path_exists: invalid path type '$which'!"
      }
    }
  }
# ###
# ### check 3 file/folder name in current dir by appending "/*"
# ###
#   set path "$path/*"
#   set fnd [list_dir $path]
# # debug_var fnd
# #### if [llength $fnd] {return 1}
#   foreach fil $fnd {
#     set fnam [lindex $fil 0]
#     set ftyp [lindex $fil 1]
#     set isfile [string compare "folder" $ftyp]
#     set nameeq ![string compare $nam $fnam]
# debug_var isfile 3
# debug_var nameeq 3
#     switch $which {
#       any  { if [expr $nameeq            ] {return 1} }
#       dir  { if [expr $nameeq && !$isfile] {return 1} }
#       file { return 0 }
#       default {
#         internal_error "path_exists: invalid path type '$which'!"
#       }
#     }
#   }
  return 0
}
} ; ### end eval namespace
