df
/
webif
forked from hummypkg/webif
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
webif/webif/lib/rsv.class

1111 lines
24 KiB
Plaintext
Executable File
Raw Blame History

source /mod/webif/lib/setup
if {![exists -proc class]} { package require oo }
if {![exists -proc sqlite3.open]} { package require sqlite3 }
require settings.class system.class
set rsvdb [sqlite3.open /var/lib/humaxtv/rsv.db]
$rsvdb query {attach database '/var/lib/humaxtv/channel.db' as channel}
if {![file exists /var/lib/humaxtv/rsvp.db]} {
file copy /var/lib/humaxtv/rsv.db /var/lib/humaxtv/rsvp.db
set tdb [sqlite3.open /var/lib/humaxtv/rsvp.db]
$tdb query {drop table TBL_VERSION}
$tdb query {alter table TBL_RESERVATION rename to pending}
$tdb query {alter table pending add column action int}
$tdb query {delete from pending}
$tdb close
}
$rsvdb query {attach database '/var/lib/humaxtv/rsvp.db' as pending}
# These are required to upgrade old tables.
catch { $rsvdb query { alter table pending add column action int} }
set binaryfields aulEventToRecordInfo
class rsv {
ulslot -1
ersvtype 0
hsvc 0
nsttime 0
szsttime "00000000000000"
nduration 0
erepeat 0
usevtid 0
szevtname {}
ulPreOffset 0
ulPostOffset 0
ulProgramId 0
ulSeriesId 0
ucVolume 0
ucInputMode 0
usChNum 0
ucRecKind 0
ucCRIDType 0
szCRID {}
szFPBRecPath {}
szRecordedProgCrid {}
szEventToRecord {}
aulEventToRecordInfo {}
bRecomRsv 0
usLastRecordedEvtId 0
eReady 0
szSvcName {}
usLcn 0
sort 0
action 0
_table ""
_origstart 0
}
require findhsvc
if {![exists -proc binary]} { package require binary }
rsv method aul {} {
set aul {}
for {set i 0} {$i < [string length $aulEventToRecordInfo]} {
incr i 16} {
binary scan [string range $aulEventToRecordInfo $i $($i + 15)]\
iiii service start end event_id
catch {lappend aul [list $service $start $end $event_id]}
}
return $aul
}
proc {rsv mkaul} {e} {
$e get_channel_info
return [binary format iiii \
[$e get channel_hsvc] \
[$e get start] \
[$e end] \
[$e get event_id] \
]
}
rsv method setaul {s} {
set aulEventToRecordInfo $s
}
rsv method clear_ulslot {} {
set ulslot -1
}
rsv method isseries {} {
if {$ucRecKind == 4} { return 1 } else { return 0 }
}
rsv method _strip {str} {
if {[string range $str 1 2] eq "i7"} {
set str [string range $str 3 end]
}
if {[string first "\025" $str] == 0} {
set str [string range $str 1 end]
}
return $str
}
rsv method folder {} {
return [$self _strip $szFPBRecPath]
}
rsv method name {} {
set name [$self _strip $szevtname]
if {$name == ""} {
switch $ersvtype {
1 { set name "--- Unnamed reminder ---" }
2 { set name "--- Unnamed manual reminder ---" }
3 { set name "--- Unnamed recording ---" }
4 { set name "--- Unnamed manual recording ---" }
5 { set name "--- Wake-up ---" }
6 { set name "--- Sleep ---" }
7 { set name "--- Auto Update ---" }
11 { set name "--- DSO Event ---" }
default { set name "--- Unknown event type $ersvtype ---" }
}
}
return $name
}
rsv method padded {} {
if {$ulPreOffset > 0 || $ulPostOffset > 0} {
return 1
} else {
return 0
}
}
rsv method channel_name {} {
return [string range $szSvcName 1 end]
}
rsv method szsttime_stamp {} {
set spaced [regsub {^(....)(..)(..)(..)(..)(..).*} \
$szsttime {\1 \2 \3 \4 \5 \6}]
if {[catch {
set stamp [clock scan $spaced -format "%Y %m %d %H %M %S"]
}]} {
return 0
}
return $stamp
}
rsv method start {} {
if {[string range $szsttime 0 3] eq "0000"} { return $nsttime }
set tm [$self szsttime_stamp]
if {$tm > 0} { return $tm }
return $nsttime
}
rsv method end {} {
return $([$self start] + $nduration)
}
rsv method icon {} {
set rsvicon ""
switch $ersvtype {
1 -
2 { set rsvicon "175_1_00_Reservation_Watch.png" }
3 -
4 { set rsvicon "175_1_11_Reservation_Record.png" }
5 { set rsvicon "745_1_10_Video_2Live.png" }
6 { set rsvicon "745_1_11_Video_1REC.png" }
7 { set rsvicon "345_6_08_ST_Ad_Hoc.png" }
}
return $rsvicon
}
rsv method RKIcon {} {
switch $ucRecKind {
2 { set RKIcon "178_1_26_Icon_Split.png" }
4 { set RKIcon "175_1_11_Series_Record.png" }
default {
switch $erepeat {
1 {set RKIcon "521_1_00_RP_Daily_C.png"}
2 {set RKIcon "521_1_00_RP_Weekly_C.png"}
3 {set RKIcon "521_1_00_RP_Weekdays_C.png"}
4 {set RKIcon "521_1_00_RP_Weekend_C.png"}
default {set RKIcon ""}
}
}
}
return $RKIcon
}
rsv method pendingicon {{width 30}} {
switch $action {
0 { set icon "add" }
1 { set icon "close" }
2 { set icon "ar" }
3 { set icon "pad" }
4 { set icon "folder" }
5 { set icon "skip" }
6 { set icon "refresh" }
}
return "<img class=va width=$width src=/img/$icon.png>"
}
rsv method iconset {{height 20}} {
set iconlist {}
set icon [$self icon]
if {$icon ne ""} {
lappend iconlist "<img src='/images/$icon' height=$height>"
if {$ersvtype == 3} {
if {[$self padded]} {
set padding "<- [expr $ulPreOffset / 60], [expr $ulPostOffset / 60] ->"
lappend iconlist \
"<img src=/img/pad.png height=$height
title=\"$padding\" alt=\"$padding\">"
} else {
lappend iconlist \
"<img src=/img/ar.png height=$height>"
}
}
}
set icon [$self RKIcon]
if {$icon ne ""} {
lappend iconlist "<img src='/images/$icon' height=$height>"
}
return $iconlist
}
rsv method setorigstart {o} {
set _origstart $o
}
rsv method set_delete {} {
set action 1
}
rsv method set_unpad {} {
set action 2
}
rsv method set_folder {name} {
set action 4
set szFPBRecPath $name
}
rsv method set_pad {{pre 60} {post 60}} {
set action 3
set ulPreOffset $pre
set ulPostOffset $post
}
rsv method set_refresh {} {
set action 6
set aulEventToRecordInfo ""
}
rsv method set_skip {event} {
set action 5
$event get_channel_info
set crid "[$event get channel_crid][$event get event_crid]"
set szRecordedProgCrid "1$crid|$szRecordedProgCrid"
set szEventToRecord [string map "1$crid| {}" $szEventToRecord]
set aulEventToRecordInfo ""
set nsttime [$event get start]
set nduration [$event get duration]
if {[$event get event_id] eq $usevtid} {
set ucVolume $usevtid
}
}
rsv method remove_pending {} {
$::rsvdb query "delete from pending where ulslot = $ulslot"
}
rsv method fix_hsvc {} {
set _hsvc [get_channel_attr $szSvcName]
if {$_hsvc eq ""} {
set _hsvc [get_channel_attr_bylcn $usLcn]
}
set hsvc $_hsvc
}
proc {rsv find_hsvc} {lcn channel} {
set _hsvc [get_channel_attr $channel]
if {$_hsvc eq ""} {
set _hsvc [get_channel_attr_bylcn $lcn]
}
return $_hsvc
}
rsv method cleanvars {} {
return [lsort [lmap i [$self vars] {
if {[string index $i 0] eq "_"} continue
concat "" $i
}]]
}
rsv method insert {{table pending} {force 0} {defer 0}} {
global rsvdb
# Duplicate check - all tables
if {!$force && $szCRID ne "" && $action == 0} {
foreach tab {pending TBL_RESERVATION} {
set rec [$rsvdb query "
select ulslot from $tab
where szCRID = '%s'
and hsvc = '%s'
" $szCRID $hsvc]
if {[llength $rec] > 0} {
throw 20 "Duplicate reservation."
return
}
}
}
# Find a spare slot.
if {$ulslot < 0} {
set slotlist [$rsvdb query "
select ulslot FROM $table
order by ulslot;
"]
if {[llength $slotlist] > 0} {
set slots [lmap i $slotlist {lindex $i 1}]
set max [lindex $i end]
for {set i 0} {$i < $max} {incr i} {
if {$i ni $slots} {
set ulslot $i
break
}
}
if {$ulslot < 0} { set ulslot $($max + 1) }
}
if {$ulslot < 0} { set ulslot 0 }
}
set fields [$self cleanvars]
foreach field {szSvcName usLcn sort} {
set df [lsearch $fields $field]
set fields [lreplace $fields $df $df]
}
if {$table ne "pending"} {
set df [lsearch $fields "action"]
set fields [lreplace $fields $df $df]
}
set vals {}
set bvals {}
foreach field $fields {
set f [$self get $field]
if {$field in $::binaryfields && [string bytelength $f] > 1} {
binary scan $f H* fx
lappend bvals $fx
lappend vals "X'%s'"
} else {
lappend bvals $f
lappend vals "'%s'"
}
}
set query "insert into ${table}("
append query [join $fields ","]
append query ") values("
append query [join $vals ","]
append query ");"
#puts $query
#puts $bvals
$rsvdb query "delete from ${table} where ulslot = $ulslot;"
$rsvdb query $query {*}$bvals
if {$table eq "pending" && !$defer} { rsv commit }
}
proc {rsv list} {{table tbl_reservation} {extra ""}} {
set qstring "
select $table.*,
channel.TBL_SVC.szSvcName, channel.TBL_SVC.usLcn,
case when ersvtype > 3 then 1 else 0 end as sort1,
case when nsttime + nduration < [clock seconds]
then 0 else 1 end as sort2
from $table
left join channel.TBL_SVC
on $table.hSvc = channel.TBL_SVC.hSvc
"
if {$extra ne ""} { append qstring $extra }
append qstring "
order by sort1, sort2 desc, nsttime
"
#puts "QSTRING: ($qstring)"
set res [$::rsvdb query $qstring]
set records {}
foreach rec $res {
lappend rec _table $table
lappend records [rsv new $rec]
}
return $records
}
proc {rsv count} {{table tbl_reservation}} {
return [llength [rsv list $table]]
}
proc {rsv lookuptab} {} {
set records {}
foreach tab {tbl_reservation pending} {
set res [$::rsvdb query "
select usSvcId, usevtid, ucCRIDType, szCRID,
ucRecKind
from $tab left join channel.TBL_SVC
on $tab.hSvc = channel.TBL_SVC.hSvc
where ersvtype <= 3
"]
foreach rec $res {
if {$rec(ucRecKind) == 4} {
set p "S"
} else {
set p "E"
}
set records([\
string tolower "$rec(usSvcId):$rec(usevtid)"]) $p
if {$rec(szCRID) eq ""} continue
if {$rec(ucCRIDType) == 49} {
set p "E"
} elseif {$rec(ucCRIDType) == 50} {
set p "S"
} else {
continue
}
set records([\
string tolower "$rec(usSvcId):$rec(szCRID)"]) $p
}
}
return $records
}
proc {rsv xlookuptab} {} {
set records {}
foreach tab {tbl_reservation pending} {
set res [$::rsvdb query "
select $tab.szCRID, channel.TBL_SVC.hSvc
from $tab left join channel.TBL_SVC
on $tab.hSvc = channel.TBL_SVC.hSvc
where ersvtype <= 3
"]
foreach rec $res {
lappend records "$rec(hSvc)/[file tail $rec(szCRID)]"
}
}
return $records
}
proc {rsv entry} {{table TBL_RESERVATION} crid svc} {
set res [$::rsvdb query "
select $table.*,
channel.TBL_SVC.szSvcName, channel.TBL_SVC.usLcn
from $table
left join channel.TBL_SVC
on $table.hSvc = channel.TBL_SVC.hSvc
where szCRID like '%%%s' and $table.hsvc = '%s'
" $crid $svc]
if {[llength $res] > 0} {
return [rsv new [lindex $res 0]]
}
return 0
}
proc {rsv fetch} {table ersvtype hsvc nsttime usevtid {crid ""} {extra ""}} {
set q "
select $table.*,
channel.TBL_SVC.szSvcName, channel.TBL_SVC.usLcn
from $table
left join channel.TBL_SVC
on $table.hSvc = channel.TBL_SVC.hSvc
where $table.ersvtype = '%s'
and $table.hsvc = '%s'
and $table.usevtid = '%s'
"
set params "$ersvtype $hsvc $usevtid"
if {$nsttime > 0} {
append q " and $table.nsttime = '%s' "
lappend params $nsttime
}
if {$crid ne ""} {
append q " and szCRID = '%s' "
lappend params $crid
}
if {$extra ne ""} {
append q " $extra "
}
set res [$::rsvdb query $q {*}$params]
if {[llength $res] > 0} {
return [rsv new [lindex $res 0]]
}
return 0
}
proc {rsv slot} {{table TBL_RESERVATION} slot} {
set res [$::rsvdb query "
select $table.*,
channel.TBL_SVC.szSvcName, channel.TBL_SVC.usLcn
from $table
left join channel.TBL_SVC
on $table.hSvc = channel.TBL_SVC.hSvc
where ulslot = %s" $slot]
if {[llength $res] > 0} {
return [rsv new [lindex $res 0]]
}
return 0
}
proc {rsv cleanup} {} {
catch {$::rsvdb close}
}
proc {rsv commit} {} {
if {![system pkginst nugget]} return
if {![[settings] rtschedule]} return
if {[catch {
exec /mod/boot/rsvsync -realtime >> /tmp/rsvsync.log} msg]} {
puts "Scheduling: $msg"
} else {
system restartpending 0
}
}
proc {rsv construct} {event type} {
global ccrid
$event get_channel_info
set args {}
set args(ersvtype) 3
set args(hsvc) [$event get channel_hsvc]
set args(nsttime) [$event get start]
set args(nduration) [$event get duration]
set args(usevtid) [$event get event_id]
set args(szevtname) "\025[$event get name]"
set args(eReady) 30
lassign [system padding] args(ulPreOffset) args(ulPostOffset)
set ccrid [$event get channel_crid]
# Fallback from series to event if there is no series CRID.
if {$type == 2 && [$event get series_crid] eq ""} {
set type 1
}
if {$type == 1} {
# Event
set args(ucCRIDType) 49
set args(ucRecKind) 1
set ecrid [$event get event_crid]
if {$ecrid ne ""} {
set args(szCRID) "$ccrid$ecrid"
set args(szEventToRecord) "1$args(szCRID)|"
set args(aulEventToRecordInfo) [rsv mkaul $event]
# Handle split events
if {[string match {*#?} $args(szCRID)]} {
set args(ucRecKind) 2
set args(szCRID) [
string range $args(szCRID) 0 end-2]
# TODO - check to see how many parts there
# are...
append args(szEventToRecord) \
$args(szEventToRecord)
}
}
} elseif {$type == 3} {
# Reminder
set args(ersvtype) 2
set args(szsttime) [clock format $args(nsttime) \
-format {%Y%m%d%H%M%S}]
} else {
# Series
set args(ucCRIDType) 50
set args(ucRecKind) 4
set args(szCRID) "$ccrid[$event get series_crid]"
set args(szFPBRecPath) "$args(szevtname)"
set events {}
set seen {}
set progs [lmap i [\
epg dbfetch dump -scrid [$event get series_crid] \
-sort start] {
if {[set ecrid [$i get event_crid]] eq ""} continue
if {$ecrid in $seen} continue
lappend seen $ecrid
if {[$i get start] < [$event get start]} {
set args(usLastRecordedEvtId) [$i get event_id]
continue
}
lappend events [rsv mkaul $i]
list "1$::ccrid$ecrid"
}]
set args(szEventToRecord) "[join $progs "|"]|"
set args(aulEventToRecordInfo) [join $events ""]
}
return [rsv new $args]
}
proc {rsv manual} {start end lcn type repeat {title ""}} {
require findhsvc
set args {}
set args(ersvtype) $type
set args(erepeat) $repeat
set args(nsttime) $start
set args(szsttime) [clock format $args(nsttime) \
-format {%Y%m%d%H%M%S}]
set args(nduration) $($end - $start)
set args(hsvc) [get_channel_attr_bylcn $lcn]
if {$title eq ""} {
set title [system strip [\
get_channel_attr_bylcn $lcn szSvcName]]
}
set args(szevtname) $title
set args(ucRecKind) 0
set args(usevtid) 0
set args(eReady) 30
return [rsv new $args]
}
proc {rsv backup} {file} {
global rsvdb
require epg.class
if {[catch { set fd [open $file w] } msg]} {
error "Error creating backup file. - $msg"
}
puts "Backing up scheduled recordings and events..."
set events [rsv list]
set fields [[rsv] cleanvars]
puts $fd "# version 2"
puts $fd "# [join $fields "\t"]"
foreach event $events {
puts " Backing up scheduled event '[$event name]'"
puts -nonewline $fd "event\t"
foreach f $fields {
set ret [$event get $f]
if {$f in $::binaryfields} {
binary scan $ret H* ret
}
puts -nonewline $fd "$ret\t"
}
puts $fd ""
}
puts "Done."
puts "Backing up channel favourites..."
set grp 0
foreach res [$rsvdb query {
select eFavGroup,
TBL_FAV.eSvcType,
substr(szSvcName, 2) as szSvcName,
favIdx
from TBL_FAV join TBL_SVC using (hSvc)
order by eFavGroup, favIdx
}] {
if {$res(eFavGroup) != $grp} {
set grp $res(eFavGroup)
puts " Group $grp"
}
puts " $res(szSvcName)"
puts $fd "fav\t$res(eFavGroup)\t$res(eSvcType)\t$res(szSvcName)\t$res(favIdx)"
}
puts "Done."
puts "Backing up channel list..."
foreach channel [epg channellist hSvc] {
lassign $channel name hsvc
puts $fd "hsvc\t$hsvc\t$name"
}
foreach channel [epg channellist usLcn] {
lassign $channel name uslcn
puts $fd "lcn\t$uslcn\t$name"
}
puts "Done."
close $fd
}
proc {rsv restore} {file} {
global rsvdb
if {![file exists $file]} {
error "Backup file <i>$file</i> does not exist."
}
if {[catch { set fd [open $file r] } msg]} {
error "Error opening <i>$file</i> - $msg"
}
puts "Restoring scheduled events from <i>$file</i>..."
$rsvdb query {begin transaction;}
$rsvdb query {delete from TBL_RESERVATION;}
set fields [[rsv] cleanvars]
set data [split [read $fd] "\n"]
set ver 1
set hsvcmap {}
set lcnmap {}
# Check version, build maps for later.
foreach line $data {
if {[string match "# version *" $line]} {
set ver [lindex [split $line " "] 2]
puts "Backup version $ver"
}
lassign [split $line "\t"] tag hsvc name
if {$tag eq "hsvc"} {
set hsvcmap($hsvc) $name
}
if {$tag eq "lcn"} {
set lcnmap($name) $hsvc
}
}
foreach line $data {
set vals [split $line "\t"]
if {[lindex $vals 0] ne "event"} continue
set vars {}
set i 0
foreach f $fields {
if {$ver < 2 && $f eq "aulEventToRecordInfo"} {
continue
}
incr i
set val [lindex $vals $i]
if {$f in $::binaryfields} {
set val [binary format H* $val]
}
lappend vars $f $val
}
# Don't restore DSO events.
if {$vars(ersvtype) == 11} continue
set rsv [rsv new $vars]
# Need to fix up channel and CRID mappings in case something
# has changed during a channel scan.
puts " Restoring [$rsv name] ([$rsv get szSvcName])"
set bad 0
# First, the service number
set ohsvc [$rsv get hsvc]
if {$ohsvc > 0} {
set hsvc [$rsv fix_hsvc]
if {$hsvc == 0} {
puts " Cannot find channel, restore failed."
set bad 1
} elseif {$hsvc != $ohsvc} {
puts -nonewline " Service number has "
puts "changed $ohsvc -> $hsvc, fixing."
} else {
puts " No change in channel service."
}
}
if {!$bad} {
# Need to fix up the AUL table service IDs too.
set newaul ""
foreach aul [$rsv aul] {
# {service start end event_id}
lassign $aul ohsvc start end eid
if {![dict exists $hsvcmap $ohsvc]} {
# Should not happen
puts " Losing AUL entry ($ohsvc)."
continue
}
set lcn 0
set channame $hsvcmap($ohsvc)
if {[dict exists $lcnmap $channame]} {
set lcn $lcnmap($channame)
}
# Find the new hsvc if possible.
set _hsvc [rsv find_hsvc $lcn $channame]
if {$_hsvc eq ""} continue
puts -nonewline " AUL $channame ($ohsvc"
if {$ohsvc != $_hsvc} {
puts -nonewline " -> $_hsvc"
}
puts ")"
append newaul [binary format iiii \
$_hsvc $start $end $eid]
}
$rsv setaul $newaul
}
if {!$bad} {
if {[catch {$rsv insert pending 1} msg]} {
puts " Error inserting event, $msg"
}
}
puts ""
}
$rsvdb query {commit transaction;}
puts "Restoring favourite channels..."
$rsvdb query {begin transaction;}
$rsvdb query {delete from channel.TBL_FAV}
$rsvdb query {drop table if exists pending.fav}
$rsvdb query {create table pending.fav (
favIdx integer primary key autoincrement unique,
hSvc integer(4),
eFavGroup integer(4),
[eSvcType] integer(4)
)}
set grp 0
foreach line $data {
set vals [split $line "\t"]
if {[lindex $vals 0] ne "fav"} { continue }
set group [lindex $vals 1]
set type [lindex $vals 2]
set chan [lindex $vals 3]
set idx [lindex $vals 4]
if {$idx eq ""} { set idx 0 }
set hsvc [get_channel_attr $chan]
if {$grp != $group} {
set grp $group
puts " Group $grp"
}
puts " $chan"
if {$hsvc eq ""} {
puts " Cannot map channel name to service."
continue
}
set query "
insert into
pending.fav(favIdx, hSvc, eFavGroup, eSvcType)
values($idx, $hsvc, $group, $type);
"
$rsvdb query $query
}
$rsvdb query {commit transaction;}
system restartpending
close $fd
}
# Returns an array of expanded events from the schedule.
# Array keys:
# 0: start
# 1: end
# 2: hSvc
# 3: event_id
# 4: Schedule ID (sid)
# 5: ucRecKind
# 6: class (live, pending)
proc {rsv allevents} {{xota 0}} {
set events [rsv list]
set pending [rsv list pending]
if {[llength $pending]} {
lappend events {*}$pending
}
set today [clock scan 00:00:00 -format "%T"]
set xevents {}
foreach e $events {
set seen 0
if {[$e get ersvtype] > 4} continue
if {[$e get action] ne "0"} continue
if {[$e start] < $today} continue
if {$xota && [$e get szevtname] eq "Disable OTA"} continue
set trailer [list \
[$e get ulslot] \
[$e get ucRecKind] \
[$e get _table] \
]
# Expand the events encoded in the AUL data.
foreach a [$e aul] {
lassign $a service start end event_id
if {$start == [$e start] && \
$end == [$e end]} {
incr seen
}
lappend xevents [list $start $end $service $event_id \
{*}$trailer]
}
if {$seen} continue
set start [$e start]
set end [$e end]
lappend xevents [list $start $end \
[$e get hsvc] [$e get usevtid] {*}$trailer]
set repeat [$e get erepeat]
switch $repeat {
1 -
3 -
4 {
# 1 Daily
# 3 Weekends
# 4 Weekdays
for {set i 0} {$i < 8} {incr i} {
incr start 86400
incr end 86400
# Sun == 0
set day [clock format [$e start] \
-format "%w"]
# Weekdays Only
if {$repeat == 3 && ($day == 0 || $day == 6)} {
continue
}
# Weekends Only
if {$repeat == 4 && $day != 0 && $day != 6} {
continue
}
lappend xevents [list \
$start $end \
[$e get hsvc] [$e get usevtid] \
{*}$trailer]
}
}
2 {
# Weekly
lappend xevents [list \
$($start + 7 * 86400) \
$($end + 7 * 86400) \
[$e get hsvc] [$e get usevtid] \
{*}$trailer]
}
}
}
return $xevents
}
proc {rsv evaluate_conflicts} {events type thresh {debug 0}} {
set conflicts {}
set slots {0 0}
foreach ev $events {
lassign $ev start end hsvc eid sid
if {$debug} {
puts "\nSLOTS: $slots"
puts $ev
}
# Close off any open slots that have now finished.
for {set i 0} {$i < 2} {incr i} {
set v [lindex $slots $i]
if {$v eq "0"} {
if {$debug} { puts "\[$i] empty." }
continue
}
lassign $v xsid xend
if {$start >= $xend} {
lset slots $i 0
if {$debug} { puts "\[$i] finished $xend." }
} else {
if {$debug} { puts "\[$i] running $xend." }
}
}
# Find slot for recording
if {[lindex $slots 0] eq "0"} {
set uslot 0
} elseif {$thresh > 1 && [lindex $slots 1] eq "0"} {
set uslot 1
} else {
# Conflict detected
if {$debug} { puts " Conflict." }
if {$type eq "xlist"} {
set c "$sid$end"
for {set i 0} {$i < 2} {incr i} {
set v [lindex $slots $i]
if {$v eq "0"} continue
lassign $v xsid xend
lappend c "$xsid$xend"
}
} else {
set c "$sid"
for {set i 0} {$i < 2} {incr i} {
set v [lindex $slots $i]
if {$v eq "0"} continue
lassign $v xsid xend
lappend c "$xsid"
}
}
foreach x $c {
if {![dict exists $conflicts $x]} {
set conflicts($x) $c
}
}
# If this events ends later than the
# existing one in slot 0, then replace that
# with this one.
lassign [lindex $slots 0] xsid xend
if {$xend >= $end} continue
if {$debug} { puts " Replacing slot 0.\n" }
set uslot 0
}
if {$debug} {
puts " -> into slot $uslot"
}
# Insert event into slot
lset slots $uslot [list $sid $end]
}
return $conflicts
}
proc {rsv newconflicts} {{thresh 1} {type "list"} {debug 0}} {
set events [lsort -index 0 -integer [rsv allevents]]
set conflicts [rsv evaluate_conflicts $events $type $thresh $debug]
if {$type eq "map"} { return $conflicts }
return [dict keys $conflicts]
}
proc {rsv checkconflict} {s d thresh {debug 0}} {
set events [rsv allevents]
lappend events [list $s $($s + $d) 0 0 0]
set events [lsort -index 0 -integer $events]
set conflicts [rsv evaluate_conflicts $events 'list' $thresh $debug]
set ret {}
if {![dict exists $conflicts "0"]} { return $ret }
foreach c [dict get $conflicts 0] {
if {$c eq "0"} continue
set s [rsv slot $c]
set s [$s name]
lappend ret $s
}
return $ret
}
Reference in New Issue View Git Blame Copy Permalink