webif/webif/lib/pkg.class

if {![exists -command class]} { package require oo }

class pkg {
	name		""
	latest		""
	descr		""
	changes		""
	url		""
	installed	""
	raw		{}
}

set ::pkgmeta {}
set ::diagmeta {}
set ::muxdb {}

pkg method _load {nm} {
	set name $nm
	set latest 0
	foreach line [split [exec /bin/opkg list $nm] "\n"] {
		# betaftpd - 0.0.8pre17-1 - Description...
		if {[string match { *} $line]} {
			append descr $line
		} else {
			set xlatest $latest
			regexp {^[^ ]+ - ([^ ]+)(?: - (.*))?$} $line x \
			    xlatest descr
			if {[pkg vercompare $xlatest $latest] > 0} {
				set latest $xlatest
			}
		}
	}
	if {$descr eq ""} {
		$self loadraw
		if {[dict exists $raw description]} {
			set descr $raw(description)
		}
	}
	regexp {(.*) \[(.*)\]} $descr x descr changes
	set info [exec /bin/opkg list-installed $nm]
	regexp {^([^ ]+) - ([^ ]+)$} $info x x installed

	return $self
}

proc {pkg instverlist} {} {{cache {}}} {
	if {[llength $cache]} { return $cache }

	# Fetch details of installed packages
	foreach line [split [exec /bin/opkg list-installed] "\n"] {
		lassign $line pkg x ver
		set cache($pkg) $ver
	}
	return $cache
}

proc {pkg repolist} {} {
	set repos {}
	foreach line [split [file read /etc/opkg/opkg.conf] "\n"] {
		lassign $line tag repo
		if {$tag eq "src/gz"} { ladd repos $repo }
	}
	return $repos
}

proc {pkg getall} {{repo base}} {
	set pkglist {}

	# Fetch details of installed packages
	set installed [pkg instverlist]

	# Now build list of all packages

	if {[catch { set fp [open "/mod/var/opkg/$repo" r] } msg]} {
		error "Error opening repository, $msg"
	}

	set pkg {}
	set cur ""
	foreach line [split [$fp read] "\n"] {
		if {![regexp {^([^:]+): (.*)$} $line x tag val]} {
			if {[string equal -length 1 $line " "]} {
				# Continuation
				if {$lasttag ne ""} {
					append pkg($lasttag) " \
					    [string trim $line]"
				}
			}
			continue
		}
		set tag [string tolower $tag]
		if {$tag eq "package"} {
			if {$pkg ne ""} {
				set pkglist($name) $pkg
			}
			set name $val
			set iver 0
			if {[dict exists $installed $val]} {
				set iver $installed($val)
			}

			set pkg [list \
			    "installed" $iver \
			    "repo" $repo \
			]
			set lasttag ""
			continue
		}
		set lasttag $tag
		set pkg($tag) $val
	}
	$fp close
	if {$pkg ne ""} {
		set pkglist($name) $pkg
	}

	return $pkglist
}

pkg method loadraw {} {
	set tag ""
	set txt ""
	set raw {}

	if {[file exists "/mod/var/opkg/info/$name.control"]} {
		set data [file read "/mod/var/opkg/info/$name.control"]
	} else {
		set data [exec /bin/opkg info $name]
	}

	foreach line [split $data "\n"] {
		if {$tag ne "" && [string match { *} $line]} {
			append raw($tag) $line
			continue
		}
		regexp {^([^:]+): (.*)$} $line x tag txt
		if {![dict exists $raw $tag]} {
			set tag [string tolower $tag]
			set raw($tag) $txt
		} else {
			set tag ""
		}
	}

	if {[dict exists $raw tags]} { set url $raw(tags) }
}

proc {pkg load} {nm} {
	return [[pkg] _load $nm]
}

pkg method is {what} {
	switch $what {
		installed {
			if {$installed eq ""} { return 0 }
			return 1
		}
		upgradable {
			if {$installed eq $latest} { return 0 }
			return 1
		}
	}
	return 0
}

proc {pkg avail} {} {
	set inst_pkgs [pkg inst]
	set avail_pkgs {}
	foreach pkg [split [exec /bin/opkg list] "\n"] {
		if {[regexp {^ } $pkg]} { continue }
		if {[regexp {^([^ ]+)} $pkg name] == 0} { continue }
		if {$name ni $inst_pkgs && $name ni $avail_pkgs} {
			lappend avail_pkgs $name
		}
		#puts "New: $name<br>"
	}
	return $avail_pkgs
}

proc {pkg inst} {} {
	# Build a list of installed packages - just the names
	set inst_pkgs {}
	foreach pkg [split [exec /bin/opkg list-installed] "\n"] {
		if {[regexp {^([^ ]+)} $pkg name] == 0} { continue }
		if {$name ni $inst_pkgs} {
			lappend inst_pkgs $name
		}
		#puts "Inst: $name<br>"
	}
	return $inst_pkgs
}

proc {pkg upgr} {} {
	#webif - 0.5.3 - 0.5.7
	set upgr_pkgs {}
	foreach pkg [split [exec /bin/opkg list-upgradable] "\n"] {
		if {[regexp {^([^ ]+)} $pkg name] == 0} { continue }
		lappend upgr_pkgs $name
		#puts "Upgr: $name<br>"
	}
	return $upgr_pkgs
}

proc {pkg loadmeta} {} {
	if {[llength $::pkgmeta]} { return }
	if {![file exists "/mod/var/pkg.meta"]} {
		catch {pkg fetchmeta}
	} else {
		set meta [open "/mod/var/pkg.meta" r]
		set ::pkgmeta [read $meta]
		$meta close
	}
}

proc {pkg loaddiagmeta} {} {
	if {[llength $::diagmeta]} { return }
	if {![file exists "/mod/var/diag.meta"]} {
		catch {pkg fetchdiagmeta}
	} else {
		set meta [open "/mod/var/diag.meta" r]
		set ::diagmeta [read $meta]
		$meta close
	}
}

proc {pkg fetchfile} {url} {
	set f [socket stream hpkg.tv:80]
	$f puts -nonewline "GET /hdrfoxt2/$url HTTP/1.1\r\n"
	$f puts -nonewline "Host: hpkg.tv\r\n"
	$f puts -nonewline "Connection: close\r\n"
	$f puts -nonewline "\r\n"

	# Skip headers in the response.
	set line [string trim [$f gets]]
	while {[string length $line]} {
		#puts "Web Header: $line"
		set line [string trim [$f gets]]
	}

	# Save the body
	set ret [$f read]
	$f close
	return $ret
}

proc {pkg fetchmeta} {} {
	set ::pkgmeta [pkg fetchfile pkg.meta]

	set ff [open "/mod/var/pkg.meta" w]
	puts $ff $::pkgmeta
	$ff close
}

proc {pkg fetchdiagmeta} {} {
	set ::diagmeta [pkg fetchfile diag.meta]

	set ff [open "/mod/var/diag.meta" w]
	puts $ff $::diagmeta
	$ff close
}

proc {pkg loadmuxdb} {} {
	if {[llength $::muxdb]} { return }
	if {![file exists "/mod/var/mux.db"]} {
		catch {pkg fetchmuxdb}
	} else {
		set meta [open "/mod/var/mux.db" r]
		set ::muxdb [read $meta]
		$meta close
	}
}

proc {pkg fetchmuxdb} {} {
	set ::muxdb [pkg fetchfile mux.db]

	set ff [open "/mod/var/mux.db" w]
	puts $ff $::muxdb
	$ff close
}

proc {pkg update} {} {
	exec /bin/opkg update
}

proc {pkg upgrade} {nm} {
	exec /bin/opkg upgrade $nm
}

proc {pkg vercompare} {v1 v2} {
	if {$v1 eq $v2} { return 0 }

	if {![regexp {^(.*)-([^-]+)$} $v1 x v1 r1]} {
		lassign [split $v1 -] v1 r1
	}

	if {![regexp {^(.*)-([^-]+)$} $v2 x v2 r2]} {
		lassign [split $v2 -] v2 r2
	}

	foreach a [split $v1 .] b [split $v2 .] {
		if {$b eq "" || $a > $b} { return 1 }
		if {$a eq "" || $a < $b} { return -1 }
	}
	if {$r2 eq "" || $r1 > $r2} { return 1 }
	if {$r1 eq "" || $r2 > $r1} { return -1 }
	return [string compare $v1 $v2]
}