|
|
frame.tcl Version 1.0
Wraps the frameAPI.so and the genericAPI.so and the
genericAPI.tcl for use by the frame API.
frame::cache() is a list of directories and the gps
timestamps of the first and last frames in those
directories.
frame.tcl requires two other frame API specific Tcl
source files:
set ::RCS_ID_frametcl {$Id: frame.tcl,v 1.667 2008/10/16 21:30:04 mlei Exp $}
set ::RCS_ID_frametcl [ string trim $::RCS_ID_frametcl "\$" ]
package provide frame 1.0
package require frameAPI
#package require frame_cache
package require frame_output
package require frame_concat
set ::last_job_start_time [ clock seconds ]
namespace eval frame {
set errlvl 1
;## the current interferometer id
set ifoid {}
;## images are pairs of jobid and framep
set images [ list ]
;## the list of pending jobs
set newjobqueue [ list ]
;## options are defined with a name, a regex pattern
;## which matches them, and a default value if applicable.
;## the variables will not get substituted at this point.
;## note that the REQUIRED options have no default and
;## will raise exceptions if not provided.
set options {
-interferometers {.*} {}
-outputformat {.*} {ilwd ascii}
-returnprotocol {.*} {}
-concatenate {^(0|\-?1)$} 0
-framequery {.+} {}
-targetapi {.*} {}
-allowgaps {^[01]$} 0
-frametarget {.*} {}
-jobid {\d+} $jobid
}
;## atoms are framequery string fragments which must be
;## properly capitalised for calculating the appropriate
;## accessor method for the framequery.
;## all dataqueries are forced to lowercase and then
;## substituted with thse patterns.
;## ORDER MATTERS!!
set atoms [ list \
FrameH Frame Proc DataQuality Data List Sim Ser Adc Dt \
NAuxParam AuxParam AuxParamNames \
Raw Channel Comment Group Valid History FShift Number \
Num Name Sample Rate Arm Xazimuth Yazimuth Elevation Phase \
Detector Latitude Longitude Xaltitude Xmidpoint Yaltitude \
Ymidpoint Time Local Msg Message Severity EventStatus Event Statistics \
Trigger Test End Start Inputs OffsetN OffsetS Probability \
Status Offset Amplitude After Before Stat Representation \
Version Strain Summary Trig ULeapS Daq Binary GTime Quality \
Attribute Units QaBitList Slope NBits Group Bias Aux Run \
BW SubType Type FRange TRange \
NParam Parameters ParameterNames \
]
}
proc frame::destructElementWrap { ptr } {
if { [ catch {
destructElement $ptr
if { [ string length [ info commands $ptr ] ] } {
# addLogEntry "rename $ptr [ info commands $ptr ] to null" purple
rename $ptr {}
}
} err ] } {
return -code error $err
}
}
proc frame::init { } {
if { [ catch {
if { ! [ info exists ::DEBUG_QUERY_EXPANSION ] } {
set ::DEBUG_QUERY_EXPANSION 0
} elseif { [ string equal false [ string tolower \
$::DEBUG_QUERY_EXPANSION ] ] } {
set ::DEBUG_QUERY_EXPANSION 0
} elseif { ! [ regexp {^[01]$} $::DEBUG_QUERY_EXPANSION ] } {
set ::DEBUG_QUERY_EXPANSION 1
}
;## ::DEBUG_FILE2PTR must follow the same rules.
if { ! [ info exists ::DEBUG_FILE2PTR ] } {
set ::DEBUG_FILE2PTR 0
} elseif { [ string equal false [ string tolower \
$::DEBUG_FILE2PTR ] ] } {
set ::DEBUG_FILE2PTR 0
} elseif { ! [ regexp {^[01]$} $::DEBUG_FILE2PTR ] } {
set ::DEBUG_FILE2PTR 1
}
;## ::DEBUG_FILECACHE must follow the same rules.
if { ! [ info exists ::DEBUG_FILECACHE ] } {
set ::DEBUG_FILECACHE 0
} elseif { [ string equal false [ string tolower \
$::DEBUG_FILECACHE ] ] } {
set ::DEBUG_FILECACHE 0
} elseif { ! [ regexp {^[01]$} $::DEBUG_FILECACHE ] } {
set ::DEBUG_FILECACHE 1
}
if { ! [ info exists ::FRAME_NEW_JOB_RATE ] } {
set ::FRAME_NEW_JOB_RATE 2
}
set msg "::FRAME_NEW_JOB_RATE is set to "
append msg "$::FRAME_NEW_JOB_RATE seconds. "
append msg "(1 to 15 seconds is usual, default "
append msg "is 2)."
addLogEntry $msg green
# if { ! [ info exist ::DUMPDIR ] } {
# set ::DUMPDIR /ldas_outgoing/test/frame_params
#}
# if { ! [ file exist $::DUMPDIR ] } {
# file mkdir $::DUMPDIR
#}
# addLogEntry "job parameters are dumped in $::DUMPDIR" purple
if { [ catch {
#frame::sanity STARTUP0
} err ] } {
addLogEntry "Frame API init error: $err" 2
puts stderr "Frame API init error: $err"
}
if { ![ info exist ::REAP_THREAD_DELAY ] } {
set ::REAP_THREAD_DELAY 5000
}
if { ! [ info exists ::DEVICE_IO_CONFIGURATION ] } {
set ::DEVICE_IO_CONFIGURATION [ list ]
}
if { ! [ info exists ::DELAY_RECV_FRAMES_FROM_DISKCACHE_SECS ] } {
set ::DELAY_RECV_FRAMES_FROM_DISKCACHE_SECS 120
}
if { [ regexp {8.4} $::tcl_version ] } {
trace add variable ::DEVICE_IO_CONFIGURATION { write } \
frame::updateDeviceIOConfiguration
trace add variable ::DEVICE_IO_CONFIGURATION { unset } \
frame::updateDeviceIOConfiguration
} else {
trace variable ::DEVICE_IO_CONFIGURATION wu \
frame::updateDeviceIOConfiguration
}
frame::updateDeviceIOConfiguration
bgLoop framejobqueue frame::newJob 3
bgLoop defunctjobs frame::defunctJobs 300
bgLoop deviceioconfig frame::bgUpdateDeviceIOConfiguration 300
} err ] } {
addLogEntry "Frame API init error: $err" 2
puts stderr "Frame API init error: $err"
}
}
proc frame::dictionary { } {
if { [ catch {
set seqpt "getFrameDictionary:"
set dic [ getFrameDictionary ]
array set ::frame::frame $dic
foreach struct [ array names ::frame::frame ] {
foreach [ list name type ] [ set ::frame::frame($struct) ] {
set ::frame::frame($struct,$name) $type
}
unset ::frame::frame($struct)
}
} err ] } {
return -code error "[ myName ]:$seqpt $err"
}
return [ llength [ array names ::frame::frame ] ]
}
supports -framequery options in several formats:Comments:
-framequery { F {H L} {} 600000000 Adc(0) } -framequery { { F H {} 600000000 Adc(0) } { R L {} 600000000 Adc(100) } }
proc frame::parseFrameQuery { jobid args } {
if { [ catch {
set retval [ list ]
if { [ llength $args ] == 1 } {
;## Determine whether this is a simple query
;## or a complex query
set qlist [ lindex $args 0 ]
if { [ llength $qlist ] == 5 && \
[ llength [ lindex $qlist 0 ] ] != 5 } {
;## This is a simple query
} else {
;## This is a complex query,
;## so modify args to be a list of
;## the component simple-queries
set args $qlist
}
}
foreach arg $args {
if { ! [ string length $arg ] } { continue }
foreach [ list types ifos times frames channels ] \
[ frame::analyzeQueryElement $jobid $arg ] { break }
lappend retval [ list $types $ifos $times $frames $channels ]
}
if { $::DEBUG_QUERY_EXPANSION } {
addLogEntry "(types ifos times frames chans): '$retval'" purple
}
} err ] } {
return -code error "[ myName ]: $err"
}
return $retval
}
proc frame::analyzeQueryElement { jobid args } {
if { [ llength $args ] == 1 } {
set args [ lindex $args 0 ]
}
if { [ catch {
set types [ list ]
set frames [ list ]
set channels [ list ]
set interferometers [ list ]
set times [ list ]
foreach [ list typs ifos frms tims ques ] $args { break }
if { ! [ string length $typs ] } { set typs R }
if { ! [ string length $ifos ] } { set ifos 0 }
set typ_length [ llength $typs ]
set ifo_length [ llength $ifos ]
set frm_length [ llength $frms ]
set tim_length [ llength $tims ]
set que_length [ llength $ques ]
foreach frame $frms {
array set temp [ frame::analyzeFilename $jobid $frame ]
set name $temp(type)
}
if { [ info exists frms_tmp ] && [ string length $frms_tmp ] } {
set frms $frms_tmp
}
;## specific channels from explicitly named
;## frames.
if { $frm_length && $que_length } {
set interferometers {}
set ifo_length 0
set types {}
set typ_length 0
if { [ regexp {\d{9,10}} $tims ] } {
set times $tims
} else {
set gps $temp(gps)
set times $gps-[ expr {$gps + $temp(tdt) - 1} ]
}
set frames $frms
set channels $ques
}
;## specific channels over some time range with
;## ifo(s) specified. this is slightly complicated
;## by the fact that frames will have channels for
;## more than one ifo, as in H0, H1 and H2 channels in
;## a Hanford frame...
if { $typ_length && $ifo_length && $tim_length && $que_length } {
foreach ifo $ifos {
set types $typs
set interferometers $ifos
set times $tims
set frames {}
set channels $ques
}
}
} err ] } {
return -code error "[ myName ]: $err"
}
return [ list $types $interferometers $times $frames $channels ]
}
proc frame::expandDataQuery { query } {
set errors [ list ]
set item [ list ]
set query_pat {(\S+)\s*\(\s*([^\)]*)\s*\)}
if { [ llength $query ] == 1 } {
set query [ lindex $query 0 ]
}
;## seed the query accessor method name
foreach item $query {
if { [ catch {
set pathological 0
set names [ list ]
;## either it matches or it doesn't, no big deal
regexp $query_pat $item -> item names
regsub {\s+} $names "," names
;## should probably be a nocase match...
;## PR #2134 - nocase where appropriate 04/13/04
switch -regexp -- $item {
{concat} { ;## this may not belong here
set op concat
}
{([Aa]ll|[Ff]ull)} {
set op fullFrame2container
set names [ list ]
}
{[Dd]etector$} {
set op DetectorProc
}
{[Dd]etector[Pp]roc} {
set op DetectorProc
}
{[Dd]etector[Ss]im} {
set op DetectorSim
}
{([Aa][Dd][Cc]|[Ss][Ee][Rr]|[Ss][Ii][Mm]|[Pp][Rr][Oo][Cc])} {
regexp -nocase {Adc|Ser|Sim|Proc} $item op
set op [ ucase -strict $op ]
}
{([Ss]tat[Dd]ata|[Ss]ummary)} {
regexp -nocase {Stat|Summary} $item op
set op [ ucase -strict $op ]
}
default {
set pathological 1
set op {}
}
}
set names [ numRange $names ]
;## expand query accessor seed into command name
;## by appending atoms to op as long as they match
;## the query string
while { 1 } {
foreach atom $::frame::atoms {
if { [ regexp -nocase -- ^$op$atom $item ] } {
set op $op$atom
break
}
;## don't leave a dangling atom if there was
;## no match
set atom {}
}
;## stop name building the first time nothing
;## matches
if { ! [ string length $atom ] } { break }
}
} err ] } {
;## collect errors, and try to continue
lappend errors $err
}
;## attach "getFrame" prefix as appropriate
if { ! [ regexp -nocase {((get|full)Frame|concat)} $op ] } {
set op getFrame$op
}
;## interpose "Data" atom if we think it's lacking
if { ! $pathological } {
if { ! [ llength [ info commands $op ] ] } {
regsub {getFrame[A-Z][a-z]+} $op {&Data} op
}
}
;## a couple of simple replacements
regsub {SimDataEvent} $op SimEvent op
regsub {SummaryData} $op Summary op
;## and test the resulting operation for existence
if { ! [ llength [ info commands $op ] ] } {
if { [ string equal getFrame $op ] } {
lappend errors "badly formed query atom: '$item'"
} else {
lappend errors "calculated operation: '$op' does not exist"
}
} else {
;## and if it does, add it to the ops list
lappend retval [ list $op $names ]
}
} ;## end of foreach
if { [ llength $errors ] && [ info exists retval ] } {
return -code error "[ myName ]: $errors"
}
if { [ info exists retval ] } {
return $retval
} else {
return -code error "[ myName ]: $errors (malformed query?)"
}
}
proc frame::getOptArray { jobid } {
set args [ list ]
set errs [ list ]
set opts [ list ]
if { [ catch {
;## automagically get all arguments which are
;## relevant to this API
foreach [ list name rx default ] $::frame::options {
set name [ string trim $name "=" ]
set name [ string tolower $name ]
if { [ info exists ::${jobid}($name) ] } {
set arg [ set ::${jobid}($name) ]
if { [ regexp -- $rx $arg ] } {
lappend args $name $arg
} else {
lappend errs "$name '$arg'"
}
}
lappend opts $name $default
}
if { [ llength $errs ] } {
return -code error "malformed arguments: $errs"
}
foreach [ list opt val ] [ expandOpts ] {
set opt [ string trim $opt - ]
lappend arglist $opt $val
}
} err ] } {
return -code error "[ myName ]: $err"
}
return $arglist
}
proc frame::newJob { { jobid "" } } {
if { [ catch {
set now [ clock seconds ]
;## get list of existing jobs
set jobqueue $::frame::newjobqueue
set ::frame::newjobqueue [ list ]
;## collect a new job if called by macro
if { [ string length $jobid ] } {
;## uplevel #1 is the operator socket handler
set cid [ set ::${jobid}(cid) ]
;## detach from the assistant manager
if { [ regexp {8.4} $::tcl_version ] } {
foreach entry [ trace info variable ::$cid ] {
foreach { oplist cmd } $entry { break }
trace remove variable ::$cid $oplist $cmd
}
} else {
trace vdelete ::$cid w "reattach $jobid $cid"
}
lappend jobqueue [ list $jobid $cid $now 0 ]
}
;## make certain that at least 5 seconds have elapsed
;## since the last job was started
set rate [ expr { $now - $::last_job_start_time } ]
if { $rate < $::FRAME_NEW_JOB_RATE } {
set ::frame::newjobqueue $jobqueue
return {}
}
set triggered 0
foreach item $jobqueue {
foreach [ list jobid cid stime metric ] $item { break }
regexp {\d+} $jobid job
set jobid $::RUNCODE$job
if { $triggered } {
;## the job goes back on the list...
lappend ::frame::newjobqueue \
[ list $jobid $cid $stime $metric ]
} elseif { [ info exists ::filecache$job ] } {
set test [ set ::filecache$job ]
if { ! [ string length $test ] } {
set err "aborted job $jobid"
frame::newJobAbort $jobid $cid $err
continue
}
if { [ llength $test ] == 1 && \
[ llength [ lindex [ join $test ] 0 ] ] == 3 } {
set ::filecache$job [ join [ set ::filecache$job ] ]
}
if { [ info exists ::DEBUG_FILECACHE ] && \
[ string equal 1 $::DEBUG_FILECACHE ] } {
addLogEntry [ set ::filecache$job ] purple
}
;## okay, we're ready to go!!
set triggered 1
set ::last_job_start_time $now
after 0 frame::newJobCallback $jobid $cid
} else {
if { ($now - $stime) > $::DELAY_RECV_FRAMES_FROM_DISKCACHE_SECS } {
set err "no frames received from diskcache API"
frame::newJobAbort $jobid $cid $err
} else {
;## the job goes back on the list...
lappend ::frame::newjobqueue \
[ list $jobid $cid $stime $metric ]
}
}
}
} err ] } {
if { [ string length $err ] } {
if { ! [ info exists cid ] } {
set cid unknown_sockid
}
frame::newJobAbort $jobid $cid $err
}
}
}
proc frame::newJobAbort { jobid cid err } {
if { [ catch {
set flag 0
regexp {\d+} $jobid job
set jobid $::RUNCODE$job
addLogEntry $err red
#set fd [ open ${::DUMPDIR}/${jobid}.params w ]
#puts $fd [ array get ::$jobid ]
#close $fd
set ::$cid [ list 3 $err error! ]
::reattach $jobid $cid
if { [ info exists ::${jobid}(Frame) ] } {
::unset ::${jobid}(Frame)
}
set flag 1
frame::killJob $jobid
} err ] } {
addLogEntry $err red
if { $flag == 0 } {
frame::killJob $jobid
}
}
}
proc frame::newJobCallback { jobid cid } {
set outfiles [ list ]
if { [ catch {
regexp {\d+} $jobid job
set jobid $::RUNCODE$job
array set opt [ frame::getOptArray $jobid ]
set rp $opt(returnprotocol)
set of $opt(outputformat)
set concat $opt(concatenate)
set targ $opt(frametarget)
set ag $opt(allowgaps)
;## Peter Shawhan asked for this (PR#823)
regsub -- {(http|ftp|file|port):([^\/])} $rp {\2} rp
;## are results going to another API?
set target $opt(frametarget)
if { [ string length $target ] } {
set api_rx ^([ join $::API_LIST | ])\$
;## determine whether the target is an api or a file
if { [ regexp -- $api_rx $target ] } {
set rp $target
}
}
;## new style complex framequery handler with
;## full backwards compatibility
set _ifos [ list ]
set _times [ list ]
set _frames [ list ]
set _dq [ list ]
set parsed_frame_query \
[ frame::parseFrameQuery $jobid $opt(framequery) ]
;## how many framequeries were chained together?
set N_queries [ llength $parsed_frame_query ]
foreach retval $parsed_frame_query {
foreach [ list _types _ifos _times _frames _dq ] $retval {
;## old style dataqueries will return a short list
if { ! [ string length $_dq ] } {
set dq $opt(framequery)
} elseif { ! [ string length $_types ] } {
set types R
set ifos $_ifos
set times $_times
set frames $_frames
set dq $_dq
} else {
set types $_types
set ifos $_ifos
set times $_times
set frames $_frames
set dq $_dq
}
foreach item { types ifos times frames dq } {
if { [ llength [ set $item ] ] == 1 } {
set $item [ lindex [ set $item ] 0 ]
}
}
}
set rawdq $dq
set dq [ frame::expandDataQuery $dq ]
;## some fancy flow control here so we can, if
;## necessary, synch up framequeries.
if { $concat != -1 && $N_queries > 1 } {
eval lappend dqs $dq
incr N_queries -1
eval lappend rawdqs $rawdq
continue
}
if { [ info exists dqs ] } {
eval lappend dqs $dq
eval lappend rawdqs $rawdq
set dq $dqs
set rawdq $rawdqs
unset rawdqs
unset dqs
}
;## default interferometer is '0'
if { ! [ llength $ifos ] } { set ifos 0 }
if { $::DEBUG_QUERY_EXPANSION } {
set debug "types: $types ifos: '$ifos' frames: '$frames' "
append debug " times: '$times' query: '$dq' "
append debug " of: '$of' rp: '$rp'"
addLogEntry $debug purple
}
foreach ifo $ifos {
foreach type $types {
lappend contptrs [ frame::runNewJob \
$jobid $concat $ifo $frames $times $dq $type \
$of $rp $ag $rawdq ]
}
}
} ;## end of foreach on -framequery option
;## we only handle output up here if we are going through
;## collectElements, which uses a special -concatenate
;## option value of '-1'.
if { $concat == -1 } {
unset ::filecache$job
set contptrs [ frame::mergePointers $jobid $contptrs ]
set contptrs [ list $jobid $contptrs ]
set outfiles [ frame::output $jobid $targ $contptrs $of ]
frame::destructImage $jobid -nocomplain
frame::managePointers $jobid destroy .+
frame::reattachMsg $jobid $cid $outfiles
reattach $jobid $cid
if { [ info exists ::$jobid ] } {
::unset ::$jobid
}
}
} err ] } {
frame::newJobAbort $jobid $cid $err
}
}
proc frame::reattachMsg { jobid cid filenames } {
if { [ catch {
set of [ set ::${jobid}(-outputformat) ]
set rp [ set ::${jobid}(-returnprotocol) ]
set target [ set ::${jobid}(-targetapi) ]
set subj [ set ::${jobid}(-subject) ]
set query [ set ::${jobid}(-framequery) ]
set ftarget [ set ::${jobid}(-frametarget) ]
;## default return value is a continuation
if { [ regexp {LIGO_LW} $of ] || \
[ string length $target ] } {
set msg [ list 0 0 0 ]
}
if { ! [ string length $subj ] } {
set subj "frame API output"
}
set protocol http
;## if the frame API is the target, and the user
;## supplied an explicit return protocol, use it.
;## otherwise use http.
if { [ string length $rp ] &&
[ regexp -nocase {frame} $target ] } {
regexp -nocase {^(file|ftp|http)} $rp protocol
set msg [ macroReturnMsg $jobid $protocol $filenames ]
set msg [ list 2 [ lindex $msg 1 ] $subj ]
;## no specified return protocol but frame is target
} elseif { [ regexp -nocase {frame} $target ] } {
set jobdir [ jobDirectory ]
regsub $::HTTPDIR $jobdir {} jobdir
set msg "Your results:\n${filenames}\ncan be found at:\n"
append msg "$::HTTPURL$jobdir/"
set msg [ list 2 $msg $subj ]
;## another API is the target, but we dropped files
;## somehow.
} elseif { ! [ info exists msg ] } {
regexp -nocase {^(file|ftp|http)} $rp protocol
set msg [ macroReturnMsg $jobid $protocol $filenames ]
set msg [ list 2 [ lindex $msg 1 ] $subj ]
}
set ::$cid $msg
} err ] } {
return -code error "[ myName ]: $err"
}
}
proc frame::runNewJob { jobid concat ifo frames times query type of rp ag rawdq } {
if { [ catch {
set contptrs [ list ]
set dir [ jobDirectory ]
set target [ set ::${jobid}(-frametarget) ]
if { [ info exists ::${jobid}(-autoexpand) ] } {
set expand 1
} else {
set expand 0
}
;## if we are going to concatenate, we need to know
;## if we're making frames or just packing up channels
if { [ regexp -nocase {frame} $of ] && $concat == 1 } {
set fo 1
} else {
set fo 0
}
if { $concat == 1 && $fo == 0 } {
frame::concatThreadProto \
$jobid $ifo $times $type $frames $of $rp $rawdq $ag
} elseif { $concat == -1 } {
set contptrs \
[ frame::collectElements $jobid $frames $times $query ]
} else {
frame::createFramesProto \
$jobid $ifo $times $type $frames \
$of $rp $rawdq $ag $concat $expand
}
} err ] } {
return -code error "[ myName ]: $err"
}
return $contptrs
}
proc frame::mergePointers { jobid contptrs } {
if { [ catch {
set seqpt {}
set ptr {}
set newcontp [ lindex $contptrs 0 ]
set newcontp [ lindex $newcontp 1 ]
if { [ llength $contptrs ] > 1 } {
set newcontp [ ilwd::newcontp ]
frame::managePointers $jobid add $newcontp
foreach pair $contptrs {
foreach [ list jobid ptr ] $pair {
set seqpt "addContainerElement($newcontp $ptr):"
::addContainerElement $newcontp $ptr
set seqpt {}
frame::managePointers $jobid delete $ptr
}
}
}
} err ] } {
return -code error "[ myName ]:$seqpt: $err"
}
return $newcontp
}
proc frame::analyzeFilename { jobid filename } {
if { [ catch {
set atoms [ frame::analyzeOfficialFilename $jobid $filename ]
if { [ llength $atoms ] == 6 } {
set frame(type) official
set frame(ifo) [ lindex $atoms 1 ]
set frame(typ) [ lindex $atoms 2 ]
set frame(gps) [ lindex $atoms 3 ]
;## we will have to use the tdt and
;## getFrameNumber to set the "N" and "dt" later
set frame(frn) {}
set frame(tdt) [ lindex $atoms 4 ]
set frame(ext) gwf
set atoms [ array get frame ]
} else {
set msg "frame filename formats not adhereing to "
append msg "the 'official' naming convention are "
append msg "no longer supported, and the frame: "
append msg "'$filename' does not conform to the "
append msg "ifo-frame_type-gps-dt.gwf format."
return -code error $msg
}
} err ] } {
return -code error "[ myName ]: $err"
}
return $atoms
}
proc frame::analyzeOfficialFilename { jobid filename } {
if { [ catch {
set atoms [ list ]
;## this regexp will return 6 elements when it
;## matches:
;## given:
;## G-R-6666666666-1.gwf
;## returns:
;## G-R-6666666666-1.gwf G R 6666666666 1 .gwf
;##
set rx {^([^-]+)-([^-]+)-(\d{1,10})-(\d+)(\.gwf)$}
set tail [ file tail [ string trim $filename ] ]
set tail [ string trim $tail ]
set atoms [ regexp -inline -- $rx $tail ]
;## if the pattern matched, but the filename was
;## somehow malformed... should not be possible
if { [ llength $atoms ] } {
if { [ regsub -all -- {-} $tail {} foo ] != 3 } {
set msg "malformed 'official' frame filename: '$tail' "
append msg "has extra '-' character(s), so does not "
append msg "conform to gps-frame_type-gps-dt.gwf format."
return -code error $msg
}
}
} err ] } {
return -code error "[ myName ]: $err"
}
return $atoms
}
proc frame::getNumber { jobid filename } {
if { [ catch {
set seqpt "openFrameFileThread($filename r):"
set ffp [ openFrameFileThread $jobid $filename r ]
set seqpt "getFrameNumber($ffp):"
set frn [ getFrameNumber $ffp ]
set seqpt "closeFrameFile($ffp):"
closeFrameFile $ffp
set ffp [ list ]
if { ! $frn } {
set msg "getFrameNumber reported '0' frames in '$filename'"
return -code error $msg
}
} err ] } {
if { [ info exists ffp ] } {
if { [ string length $ffp ] } {
catch { closeFrameFile $ffp }
}
}
return -code error "[ myName ]:$seqpt $err"
}
return $frn
}
proc frame::rationalizedFilenameData { jobid filename } {
if { [ catch {
array set temp [ frame::analyzeFilename $jobid $filename ]
set gps $temp(gps)
set dt $temp(tdt)
set N $temp(frn)
if { ! [ string length $N ] } { set N 1 }
if { ! [ string length $dt ] } { set dt 1 }
set tdt [ expr { $N * $dt } ]
;## if we have an unparsible frame name, go for broke!!
if { [ string equal $temp(type) unknown ] } {
set gps 0
set dt 1
set N 1
set tdt 1
}
set type $temp(typ)
} err ] } {
return -code error "[ myName ]: $err"
}
return [ list $type $gps $N $dt $tdt ]
}
proc frame::collectElements { jobid frames times query } {
if { [ catch {
set ptrs [ list ]
set errs [ list ]
regexp {\d+} $jobid job
set jobid $::RUNCODE$job
foreach [ list times frames ] \
[ frame::fixTimesAndFrames $times $frames ] { break }
array set block \
[ frame::matchTimesAndFrames $jobid $times $frames ]
set contp [ ilwd::newcontp ]
frame::managePointers $jobid add $contp
setElementAttribute $contp comment "$jobid $frames $query"
foreach frame $frames {
if { ! [ string length $frame ] } { continue }
set ptrs [ list ]
set times $block($frame)
foreach [ list type gps N fdt tdt ] \
[ frame::rationalizedFilenameData $jobid $frame ] { break }
if { ! $gps } { set gps [ lindex $times 0 ] }
set framep [ frame::file2ptr $jobid $frame ]
foreach time $times {
set id [ file tail $frame ]
foreach item $query {
foreach [ list method chans ] $item { break }
if { ! [ llength $chans ] } { set chans 0 }
if { [ regexp {(\d+)-(\d+)} $time -> start end ] } {
set deltat [ expr { $end - $start } ]
} else {
set start [ lindex $time 0 ]
set deltat 1
}
if { $start > $gps && $start < ($gps + $fdt) } {
set offset [ expr { $start - $gps } ]
} else {
set offset 0
}
set exp !${offset}!${deltat}!
if { [ catch {
foreach chan $chans {
;## is it a resample request?
foreach [ list chan resample ] \
[ frame::resampleParser $chan ] { break }
if { ! [ regexp {!} $chan ] } {
set chan $chan$exp
}
set ptr \
[ frame::method2ptr $jobid $item $chan $id 1 $resample ]
ilwd::addElement $ptr $contp
frame::destructElementWrap $ptr
}
} err ] } {
lappend errs "$id: $err"
}
}
} ;## end of foreach on time
update
}
if { [ llength $errs ] } {
return -code error $errs
}
} err ] } {
return -code error "[ myName ]: $err"
}
return [ list $jobid $contp ]
}
proc frame::fixTimesAndFrames { times frames } {
if { [ catch {
set jobid [ uplevel set jobid ]
regexp {\d+} $jobid job
set jobid $::RUNCODE$job
set intimes $times
set inframes $frames
if { ! [ string length [ lindex $frames 0 ] ] } {
set frames [ set ::filecache$job ]
if { [ llength $frames ] == 1 } {
set frames [ lindex $frames 0 ]
}
;## cache::concatGetFilenames could return a list
;## of three elements, times frames and gapflag...
;## maybe can't happen here.
if { [ regexp {^\d{9,10}-\d{9,10}$} [ lindex $frames 0 ] ] } {
set times [ lindex $frames 0 ]
set frames [ lindex $frames 1 ]
}
}
if { ! [ string length $times ] } { set times 0 }
if { [ llength $times ] == 1 } {
set times [ lindex $times 0 ]
}
if { [ llength $frames ] == 1 } {
set frames [ lindex $frames 0 ]
}
if { $::DEBUG_QUERY_EXPANSION } {
set msg "times_in: '$intimes' frames_in: '$inframes' "
append msg "times_out: '$times' frames_out: '$frames'"
addLogEntry $msg purple
}
} err ] } {
return -code error "[ myName ]: $err"
}
return [ list $times $frames ]
}
proc frame::matchTimesAndFrames { jobid times frames } {
if { [ catch {
set ranges [ list ]
set intimes $times
set times [ numRange $times ]
set inframes $frames
foreach frame $frames {
array set temp [ frame::analyzeFilename $jobid $frame ]
set N $temp(frn)
if { ! [ string length $N ] } { set N 1 }
set dt $temp(tdt)
if { ! [ string length $dt ] } { set dt 1 }
set start $temp(gps)
set dt [ expr { $N * $dt } ]
set end [ expr $start + $dt ]
set timedata($frame) [ list ]
if { [ string equal 0 $times ] } {
set times $start
}
;## we CAN prune the time list because a single
;## grouping of frames will be uniquely matched.
;## other matching frames will be grouped seperately.
set i 0
set tmp [ list ]
foreach time $times {
if { $time >= $start && $time < $end } {
lappend timedata($frame) $time
} elseif { $time < $start } {
lappend tmp $time
} elseif { $time >= $end } {
set tmp [ concat $tmp [ lrange $times $i end ] ]
break
}
incr i
}
set times $tmp
;## collapse timedata into ranges
if { [ llength $timedata($frame) ] } {
set t0 [ lindex $timedata($frame) 0 ]
set tend $t0
set ranges [ list ]
foreach time [ lrange $timedata($frame) 1 end ] {
if { $time == $tend + 1 } {
set tend $time
} else {
if { $t0 == $tend } {
lappend ranges $t0
} else {
lappend ranges ${t0}-$tend
}
set t0 $time
set tend $t0
}
}
if { $t0 == $tend } {
lappend ranges $t0
} else {
lappend ranges ${t0}-$tend
}
set timedata($frame) $ranges
} ;## end of collapse of time data
set last [ lindex $ranges end ]
if { [ regexp {(\d+)-(\d+)} $last -> start end ] } {
set last ${start}-[ expr { $end + 1 } ]
} elseif { [ llength $timedata($frame) ] == 1 } {
set last $timedata($frame)
} else {
set last ${end}-[ expr { $end + 1 } ]
}
set timedata($frame) [ lreplace $ranges end end $last ]
} ;## end of foreach on frames
if { $::DEBUG_QUERY_EXPANSION } {
set msg "times_in: '$intimes' frames_in: '$inframes' "
foreach frame [ array names timedata ] {
append msg "times in '$frame': '$timedata($frame)'"
}
addLogEntry $msg purple
}
} err ] } {
return -code error "[ myName ]: $err"
}
return [ array get timedata ]
}
proc frame::timeWindow { jobid ptr { offset 0 } { dt 1 } } {
if { [ catch {
set seqpt {}
if { $offset == 0 && $dt == 0 } {
set err "offset and dt both '0'! "
append err "a channel with a dt of 0 would result."
return -code error $err
}
if { [ regexp {(Adc|Proc)} $ptr type ] } {
set seqpt "getFrame${type}DataSlice($ptr $offset $dt):"
set outptr [ getFrame${type}DataSlice $ptr $offset $dt ]
frame::managePointers $jobid add $outptr
frame::managePointers $jobid destroy $ptr
} else {
set outptr $ptr
}
} err ] } {
return -code error "[ myName ]:$seqpt $err"
}
return $outptr
}
proc frame::inFrame { jobid filename { offset 0 } { delta 1 } } {
if { [ catch {
array set finfo [ frame::analyzeFilename $jobid $filename ]
set seqpt "openFrameFileThread($filename r):"
set fp [ openFrameFileThread $jobid $filename r ]
set seqpt {}
frame::managePointers $jobid add $fp
;## if the file has more than one frame
if { $finfo(frn) > 1 } {
;## set the max frame offset to n
set n $finfo(frn)
} else {
;## otherwise set it to 1
set n 1
}
set seqpt "getFrameNumber($filename $fp):"
set N [ getFrameNumber $fp ]
if { $N != $n } {
return -code error "$filename has '$N' frames, not '$n'"
}
set seqpt {}
;## calculate time offset to nearest second (round up)
set delta [ expr { double($delta) / $finfo(tdt) } ]
set delta [ expr { int(ceil($delta)) } ]
set framen [ expr { $offset + $delta } ]
if { $framen > $N } {
return -code error "offset > N for $filename: $framen > $N"
}
set i 0
while { [ incr i ] <= $framen } {
set seqpt "readFrame($fp):"
set framep [ readFrame $fp ]
}
set seqpt {}
frame::managePointers $jobid add $framep
frame::setImage $jobid $filename $framep
} err ] } {
frame::managePointers $jobid destroy .+
return -code error "[ myName ]:$seqpt $err"
}
return $framep
}
proc frame::method2ptr { jobid item index frame { ilwd 1 } { resample 0 } } {
set seqpt {}
set ptr [ list ]
;## index 0 has inner accessor, index 1 has outer accessor.
;## if 0 and 1 are identical there is no inner accessor call.
set class_rx {(getFrame[A-Z][a-z]+(?:Data|Event)?)(\S*)}
;## identifies an ilwd pointer as opposed to a framecpp ptr
set ilwd_rx {^_[0-9a-f]+_p_Ldas(Element|Container|ArrayBase)$}
;## a stat structure
set stat_rx {(getFrameStatData)([a-zA-Z]+)?}
set frame_rx {^getFrame(Adc|Proc|Sim|Ser|Stat)Data$}
if { [ catch {
if { [ file exists $frame ] } {
set framep [ frame::open_r $jobid $frame ]
} else {
foreach [ list frame framep ] [ frame::getImage $jobid ] {
break
}
}
if { [ info exists ::DEBUG_METHOD2PTR ] && \
[ string equal 1 $::DEBUG_METHOD2PTR ] } {
set msg "frame: $frame channel: $index method: $item"
addLogEntry $msg purple
}
foreach [ list type gps N fdt tdt ] \
[ frame::rationalizedFilenameData $jobid $frame ] { break }
foreach [ list idx off dt ] \
[ frame::parseChannelSlice $index ] { break }
;## class_rx matches all methods. inner accessor
;## points to structure, outer accessor points to
;## element of structure IF different from inner.
set method [ lindex $item 0 ]
set inner $method
set outer $method
regexp $class_rx $method inner outer
;## are we slicing?
if { $dt != $fdt && [ regexp {(Adc|Proc)Data$} $inner ] } {
set ptr [ frame::timeSliceChannel \
$jobid $frame [ list $outer $index ] $off $dt ]
;## at this point the offset and dt need to be set to 0
;## if the Proc structure did NOT contain time series data.
;## and we know that because samplerate will be '-1'.
if { [ regexp {Proc} $ptr ] } {
set seqpt "getFrameProcDataType($ptr):"
set samplerate [ getFrameProcDataType