| File | /wise/base/deliv/dev/lib/perl/WISE/Ingest/HK.pm | Statements Executed | 36 | Total Time | 0.010086 seconds |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine | |
|---|---|---|---|---|---|---|
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | BEGIN |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | _isopt |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | backfill |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | coldefs |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | datime_to_et |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | datime_to_utc |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | datime_to_utc_s |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | drop_db |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | file_ets |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | files |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | hktbl |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | init_db |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | load_rows |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | mnem_tbl_name |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | mnem_tbl_rows |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | mnemonics |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | naif |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | nearest |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | new |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | open_db |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | read_and_load |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | read_file |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | read_files |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | sql_query |
| 0 | 0 | 0 | 0 | 0 | WISE::Ingest::HK:: | t_query |
| Line | Stmts. | Exclusive Time | Avg. | Code |
|---|---|---|---|---|
| 1 | #! /usr/bin/env perl | |||
| 2 | ||||
| 3 | 3 | 2.9e-5 | 9.7e-6 | use strict; # spent 11µs making 1 call to strict::import |
| 4 | 3 | 8.2e-5 | 2.7e-5 | use warnings; # spent 26µs making 1 call to warnings::import |
| 5 | ||||
| 6 | package WISE::Ingest::HK; | |||
| 7 | ||||
| 8 | 1 | 1.0e-6 | 1.0e-6 | my $pkg = __PACKAGE__; |
| 9 | ||||
| 10 | use WISE::Env ( | |||
| 11 | 1 | 9.0e-6 | 9.0e-6 | mod => __PACKAGE__, # spent 944µs making 1 call to WISE::Env::import |
| 12 | cfglib => '<:LIB:>', | |||
| 13 | version => '$Id: HK.pm 5994 2009-10-15 19:58:53Z tim $ ', | |||
| 14 | 2 | 2.3e-5 | 1.2e-5 | ); |
| 15 | ||||
| 16 | 3 | 3.6e-5 | 1.2e-5 | use Exporter::Lite; # spent 57µs making 1 call to Exporter::Lite::import |
| 17 | 3 | 0.00018 | 5.9e-5 | use vars qw(@ISA @EXPORT_OK); # spent 54µs making 1 call to vars::import |
| 18 | 1 | 2.0e-6 | 2.0e-6 | @EXPORT_OK = (); |
| 19 | ||||
| 20 | sub _isopt { | |||
| 21 | my $r = @_ ? shift : $_; | |||
| 22 | return ref($r)=~/hash/i && ! UNIVERSAL::isa($r,__PACKAGE__); | |||
| 23 | } | |||
| 24 | ||||
| 25 | 1 | 3.1e-5 | 3.1e-5 | my ($err, $warn) = WISE::Env->err_prefix(); # spent 34µs making 1 call to WISE::Env::err_prefix |
| 26 | ||||
| 27 | 3 | 7.2e-5 | 2.4e-5 | use Clone; # spent 76µs making 1 call to Exporter::import |
| 28 | 3 | 5.1e-5 | 1.7e-5 | use WISE; # spent 1.01ms making 1 call to WISE::import |
| 29 | 3 | 0.00293 | 0.00098 | use DBI; # spent 83µs making 1 call to Exporter::import |
| 30 | 3 | 0.00662 | 0.00221 | use Time::HiRes qw(time); # spent 161µs making 1 call to Time::HiRes::import |
| 31 | ||||
| 32 | 1 | 4.0e-6 | 4.0e-6 | my %cadences = (fast => 1, medium => 5, slow => 10); # !!! fake |
| 33 | 1 | 1.0e-6 | 1.0e-6 | my @coldefs; |
| 34 | 1 | 1.0e-6 | 1.0e-6 | my @mnem; |
| 35 | 1 | 0 | 0 | my $mnem_rows; |
| 36 | 1 | 0 | 0 | my $mnem_nrows; |
| 37 | ||||
| 38 | sub new { | |||
| 39 | my $class = shift; # WISE::Ingest::HK | |||
| 40 | my $opts = @_ && _isopt($_[-1]) ? pop : {}; | |||
| 41 | my $dir = shift || $opts->{hkdir}; | |||
| 42 | my $this = {}; | |||
| 43 | my $naif = $opts->{naif}; | |||
| 44 | my $verbose = $opts->{verbose}; | |||
| 45 | my $iam = "$pkg/new"; | |||
| 46 | $class = ref($class) || $class; | |||
| 47 | ||||
| 48 | $this->{dir} = $dir; | |||
| 49 | $this->{verbose} = $opts->{verbose}; | |||
| 50 | $this->{debug} = $opts->{debug}; | |||
| 51 | $this->{prefix} = $opts->{prefix} || "WIS_WTCCS_"; | |||
| 52 | $this->{form} = $opts->{form} || "zip"; | |||
| 53 | $this->{glob} = $opts->{glob} || "$this->{prefix}*.$this->{form}"; | |||
| 54 | $this->{z} = $opts->{z} || "gz"; | |||
| 55 | $this->{dbdir} = $opts->{dbdir} || "/wise/fops/ref/mos/hk"; | |||
| 56 | $this->{dbbase} = $opts->{dbbase} || "hk"; | |||
| 57 | $this->{dbfile} = $opts->{dbfile} || "$this->{dbdir}/$this->{dbbase}.db"; | |||
| 58 | $this->{dbhktbl} = $opts->{dbhktbl} || "hk"; | |||
| 59 | if(! $naif) { | |||
| 60 | $naif = WISE::Ingest::NAIF->new() or die; | |||
| 61 | } | |||
| 62 | $this->{naif} = $naif; | |||
| 63 | $this->{ixbin} = $opts->{ixbin} || 200; | |||
| 64 | $this->{atrow} = 0; | |||
| 65 | ||||
| 66 | $this->{mnemonics} = $opts->{mnemonics} | |||
| 67 | || "$this->{dbdir}/$this->{dbbase}-mnemonics.tbl"; | |||
| 68 | my $z = $this->{z}; | |||
| 69 | my $files = $opts->{files} || | |||
| 70 | ($dir | |||
| 71 | ? [grep {-e $_ && ! -z _} glob("$dir/$this->{glob}"), | |||
| 72 | grep {-e $_ && ! -z _} glob("$dir/$this->{glob}.$z")] | |||
| 73 | : undef); | |||
| 74 | $this->{files} = $files; | |||
| 75 | ||||
| 76 | if($files && $verbose) { | |||
| 77 | print "$iam: Found ".@$files." HK files ". | |||
| 78 | (! $opts->{files} | |||
| 79 | ? "from glob '$dir/$this->{glob}'" | |||
| 80 | : "specified" | |||
| 81 | ).".\n"; | |||
| 82 | } | |||
| 83 | ||||
| 84 | coldefs($this); # Load col def.s into file lexical @coldefs. | |||
| 85 | ||||
| 86 | if($files && @$files) { | |||
| 87 | for my $file (@$files) { | |||
| 88 | my ($type) = $file =~ /$this->{prefix}_([^_]+)/ or next; | |||
| 89 | # !!! No real types, all are 'VALUE' | |||
| 90 | $this->{files}{types}{$file} = $type; | |||
| 91 | # !!! Cadences from mnemonic file. Need error check | |||
| 92 | #my $cadence = $cadences{$type} || 1; | |||
| 93 | #$this->{files}{cadences}{$file} = $cadence; | |||
| 94 | } | |||
| 95 | } | |||
| 96 | ||||
| 97 | bless $this, $class; | |||
| 98 | ||||
| 99 | if(! $opts->{manual}) { # Do normal, expected stuff to dbms | |||
| 100 | if($opts->{init}) { | |||
| 101 | if($opts->{drop}) { | |||
| 102 | $this->drop_db(); | |||
| 103 | } | |||
| 104 | $this->init_db(); | |||
| 105 | } | |||
| 106 | $this->open_db() if ! $this->{db}; | |||
| 107 | } | |||
| 108 | ||||
| 109 | return $this; | |||
| 110 | } | |||
| 111 | ||||
| 112 | sub naif { | |||
| 113 | my $this = shift; | |||
| 114 | my $opts = @_ && _isopt($_[-1]) ? pop : {}; | |||
| 115 | my $naif = shift; | |||
| 116 | if(defined $naif) { | |||
| 117 | $this->{naif} = $naif; | |||
| 118 | } | |||
| 119 | return $this->{naif}; | |||
| 120 | } | |||
| 121 | ||||
| 122 | sub sql_query { | |||
| 123 | my $this = shift; | |||
| 124 | my $opts = @_ && _isopt($_[-1]) ? pop : {}; | |||
| 125 | my $sql = shift || $opts->{sql}; | |||
| 126 | my $cols = $opts->{cols}; | |||
| 127 | my $max = $opts->{max}; | |||
| 128 | my $d = $this->{db}; | |||
| 129 | my $iam = "$pkg/sql"; | |||
| 130 | $cols = $cols ? (! ref $cols ? [$cols] : (@$cols ? $cols: undef)) : undef; | |||
| 131 | die "$err: DB not open, can't query.\n" if ! $d; | |||
| 132 | die "$err: Empty query.\n" if ! $sql; | |||
| 133 | if($sql !~ /\bwhere\s/i) { # Bare where clause without the 'where' | |||
| 134 | $sql = "from $this->{dbhktbl} where $sql"; | |||
| 135 | } | |||
| 136 | if($sql !~ /^\s*select\s/i) { # No select provided | |||
| 137 | my $ccols = $cols ? join(",",@$cols) : "*"; | |||
| 138 | $sql = "select $ccols $sql"; | |||
| 139 | } | |||
| 140 | if($sql !~ /\bfrom\s/i) { # No from clause | |||
| 141 | $sql =~ s/\bwhere\s/ from $this->{dbhktbl} where /; | |||
| 142 | } | |||
| 143 | $sql .= " order by et" if $opts->{sort}; | |||
| 144 | my $t0 = time(); | |||
| 145 | print "$iam: Running SQL query '$sql' ...\n" if $this->{verbose}; | |||
| 146 | my $sth = $d->prepare($sql); | |||
| 147 | $sth->execute(); | |||
| 148 | my $hcols = ! $cols ? {} : {map { (lc $_=>1) } @$cols}; | |||
| 149 | print "$iam: Complete in ".(time()-$t0)." secs. Fetching ...\n" | |||
| 150 | if $this->{verbose}; | |||
| 151 | $t0 = time(); | |||
| 152 | my $res = $sth->fetchall_arrayref($hcols, $max); | |||
| 153 | print "$iam: Returned ".@$res." rows in ".(time()-$t0)." secs.\n" | |||
| 154 | if $this->{verbose}; | |||
| 155 | $sth->finish(); | |||
| 156 | return $res; | |||
| 157 | } | |||
| 158 | ||||
| 159 | sub t_query { | |||
| 160 | my $this = shift; | |||
| 161 | my $opts = @_ && _isopt($_[-1]) ? pop : {}; | |||
| 162 | my $dat = shift || $opts->{t}; | |||
| 163 | $dat = [$dat] if $dat && ! ref $dat; | |||
| 164 | my $at = $opts->{at}; | |||
| 165 | my $slop = $opts->{slop} // 30; | |||
| 166 | my $byrow = $opts->{byrow}; | |||
| 167 | my $byunixt = $opts->{byunixt}; | |||
| 168 | my $mnems = $opts->{mnemonics} || $this->mnemonics(); | |||
| 169 | $mnems = [$mnems] if ! ref $mnems; | |||
| 170 | my @et; | |||
| 171 | my $res; | |||
| 172 | if(! $at) { | |||
| 173 | # Range (normal) | |||
| 174 | my @dat = @$dat; | |||
| 175 | if(@dat == 1) { push @dat, @dat; } | |||
| 176 | $et[0] = $this->datime_to_et($dat[0],{dt=>-$slop}); | |||
| 177 | $et[1] = $this->datime_to_et($dat[1],{dt=>+$slop}); | |||
| 178 | $res = $this->sql_query("et between $et[0] and $et[1]", | |||
| 179 | {cols=>$opts->{cols},sort=>1}); | |||
| 180 | } else { | |||
| 181 | # Exact times | |||
| 182 | for (@$dat) { | |||
| 183 | push @et, $this->datime_to_et($_); | |||
| 184 | } | |||
| 185 | $res = $this->sql_query("et in (".join(",",@et).")", | |||
| 186 | {cols=>$opts->{cols},sort=>1}); | |||
| 187 | } | |||
| 188 | my $n = @$res; | |||
| 189 | my %index; | |||
| 190 | my $itlast = 0; | |||
| 191 | my $binsz = $this->{ixbin}; | |||
| 192 | $index{0} = 0; | |||
| 193 | for my $i (0..$n-1) { | |||
| 194 | # Save active cols for each row too | |||
| 195 | $res->[$i]{cols} = [ grep {length($res->[$i]{$_}//'')} @$mnems ]; | |||
| 196 | next if $i == 0; # Can only index starting at the 2nd row | |||
| 197 | my $t = $res->[$i]{et} - $res->[0]{et} + 0; | |||
| 198 | my $it = int($t / $binsz); | |||
| 199 | $index{$it} = $i if ! defined $index{$it}; | |||
| 200 | if($it > $itlast+1) { | |||
| 201 | for my $jt ($itlast+1..$it-1) { | |||
| 202 | $index{$jt} = $index{$itlast} | |||
| 203 | } | |||
| 204 | } | |||
| 205 | $itlast = $it; | |||
| 206 | } | |||
| 207 | ||||
| 208 | $this->{res} = $res; | |||
| 209 | $this->{index} = \%index; | |||
| 210 | ||||
| 211 | return $res; | |||
| 212 | } | |||
| 213 | ||||
| 214 | sub backfill { | |||
| 215 | my $this = shift; | |||
| 216 | my $opts = @_ && _isopt($_[-1]) ? pop : {}; | |||
| 217 | my $res = shift || $this->{res}; | |||
| 218 | return $res if ! ref $res; | |||
| 219 | # Fill in blanks from history | |||
| 220 | my %lastgood; | |||
| 221 | for my $row (@$res) { | |||
| 222 | $lastgood{$_} = $row->{$_} | |||
| 223 | for grep { length($row->{$_}//'') } keys %$row; | |||
| 224 | $row = { %lastgood }; | |||
| 225 | } | |||
| 226 | return $res; | |||
| 227 | } | |||
| 228 | ||||
| 229 | # Nearest match for all (or named) mnemonics for latest query result | |||
| 230 | sub nearest { | |||
| 231 | my $this = shift; | |||
| 232 | my $opts = @_ && _isopt($_[-1]) ? pop : {}; | |||
| 233 | my $t = shift; | |||
| 234 | my $data = shift || $this->{res}; | |||
| 235 | my $iam = "$pkg/near"; | |||
| 236 | if(! $data) { | |||
| 237 | warn "$err: Nearest match requested but no query results seen.\n"; | |||
| 238 | return; | |||
| 239 | } | |||
| 240 | my $mnems = $opts->{mnemonics} || $this->mnemonics(); | |||
| 241 | $mnems = [$mnems] if ! ref $mnems; | |||
| 242 | my $naif = $this->{naif}; | |||
| 243 | my $et = $naif->etordate2et($t,{unixt=>$opts->{unixt}}); | |||
| 244 | my $utc = $naif->et2utc($et); | |||
| 245 | my $index = $this->{index}; | |||
| 246 | my $et0 = $data->[0]{et}; | |||
| 247 | my $et1 = $data->[-1]{et}; | |||
| 248 | my $binsz = $this->{ixbin}; | |||
| 249 | my $t0 = time(); | |||
| 250 | print "$iam: Looking for ".@$mnems." cols nearest to $utc ...\n" | |||
| 251 | if $opts->{verbose}; # Don't use the global $this->{verbose} | |||
| 252 | my %row; | |||
| 253 | my %dt_min; | |||
| 254 | @dt_min{@$mnems} = (1e30) x @$mnems; | |||
| 255 | my %i_min; | |||
| 256 | @i_min{@$mnems} = (undef) x @$mnems; | |||
| 257 | my $i_min; | |||
| 258 | if($et >= $et1) { $i_min = $#{$data}; } | |||
| 259 | elsif($et <= $et0) { $i_min = 0; } | |||
| 260 | else { | |||
| 261 | my $ix = int(($et - $data->[0]{et}) / $binsz); | |||
| 262 | my $i0 = $index->{$ix-1} || 0; | |||
| 263 | my $i1 = $index->{$ix+1} || $#{$data}; | |||
| 264 | if($i1 == $i0) { $i1 = $i0+1 } | |||
| 265 | for my $i ($i0..$i1) { | |||
| 266 | my $rowmnems = $data->[$i]{cols}; | |||
| 267 | my $adt = abs($data->[$i]{et} - $et); | |||
| 268 | $dt_min{$_} = $adt, $i_min{$_} = $i | |||
| 269 | for (grep {$adt < $dt_min{$_}} @$rowmnems); | |||
| 270 | } | |||
| 271 | } | |||
| 272 | my $mindt; | |||
| 273 | for my $mnem (@$mnems) { | |||
| 274 | my $i; | |||
| 275 | if(defined ($i = $i_min // $i_min{$mnem})) { | |||
| 276 | my $dt = $data->[$i]{et} - $et; | |||
| 277 | $row{$mnem} = $data->[$i]{$mnem}; | |||
| 278 | $row{$mnem.'_dt'} = $dt; | |||
| 279 | $mindt = (! defined $mindt || abs($dt)<abs($mindt) | |||
| 280 | ? $dt | |||
| 281 | : $mindt); | |||
| 282 | } | |||
| 283 | } | |||
| 284 | warn "$warn: No H/K found matching time $utc.\n" | |||
| 285 | if ! defined $mindt; | |||
| 286 | print "$iam: Matched within $mindt secs in ".(time()-$t0)." secs.\n" | |||
| 287 | if $opts->{verbose}; # Don't use the global $this->{verbose} | |||
| 288 | return \%row; | |||
| 289 | } | |||
| 290 | ||||
| 291 | sub datime_to_utc_s { | |||
| 292 | my $this = shift; | |||
| 293 | my $opts = @_ && _isopt($_[-1]) ? pop : {}; | |||
| 294 | my $dat = shift || $opts->{t}; | |||
| 295 | my $dt = $opts->{dt} // 0; | |||
| 296 | my $t = WISE::Time::Str_time($dat,{z=>1}) | |||
| 297 | or die "$err: Unable to convert date/time '$_'.\n"; | |||
| 298 | $t += $dt; | |||
| 299 | $t = int($t); | |||
| 300 | my $utc = WISE::Time::Time_str($t,{form=>5}); | |||
| 301 | (my $utc_s = $utc) =~ s/\.\d+//; | |||
| 302 | return $utc_s; | |||
| 303 | } | |||
| 304 | ||||
| 305 | sub datime_to_utc { | |||
| 306 | my $this = shift; | |||
| 307 | my $opts = @_ && _isopt($_[-1]) ? pop : {}; | |||
| 308 | my $dat = shift || $opts->{t}; | |||
| 309 | my $t = WISE::Time::Str_time($dat,{z=>1}) | |||
| 310 | or die "$err: Unable to convert date/time '$_'.\n"; | |||
| 311 | return WISE::Time::Time_str($t,{form=>5,dp=>3}); | |||
| 312 | } | |||
| 313 | ||||
| 314 | sub datime_to_et { | |||
| 315 | my $this = shift; | |||
| 316 | my $opts = @_ && _isopt($_[-1]) ? pop : {}; | |||
| 317 | my $dat = shift || $opts->{t}; | |||
| 318 | my $naif = $this->{naif}; | |||
| 319 | my $et = $naif->etordate2et($dat,{unixt=>$opts->{unixt}}) | |||
| 320 | or die "$err: Unable to convert date/time '$_' to ET.\n"; | |||
| 321 | return $et; | |||
| 322 | } | |||
| 323 | ||||
| 324 | # Drop (move out of way) a DB file | |||
| 325 | sub drop_db { | |||
| 326 | my $this = shift; | |||
| 327 | my $opts = shift || {}; | |||
| 328 | my $file = shift || $this->{dbfile}; | |||
| 329 | my $iam = "$pkg/drop"; | |||
| 330 | return 1 if ! -e $file; | |||
| 331 | print "$iam: Dropping DB '$file' ...\n" if $this->{verbose}; | |||
| 332 | rename($file,"$file.save") or die "$err: Unable to rename '$file'; $!.\n"; | |||
| 333 | return 1; | |||
| 334 | } | |||
| 335 | ||||
| 336 | sub open_db { | |||
| 337 | my $this = shift; | |||
| 338 | my $opts = shift || {}; | |||
| 339 | my $file = shift || $this->{dbfile}; | |||
| 340 | my $iam = "$pkg/open"; | |||
| 341 | print "$iam: Opening DB '$file' ...\n" if $this->{verbose}; | |||
| 342 | return 1 if $this->{db}; | |||
| 343 | my $d=DBI->connect("DBI:SQLite:dbname=$file","","",{RaiseError=>1}); | |||
| 344 | $this->{db} = $d; | |||
| 345 | return $d; | |||
| 346 | } | |||
| 347 | ||||
| 348 | # Initalize DBMS (only needs to be done for first run or after a drop) | |||
| 349 | sub init_db { | |||
| 350 | my $this = shift; | |||
| 351 | my $opts = shift || {}; | |||
| 352 | my $iam = "$pkg/init"; | |||
| 353 | $this->open_db() if ! $this->{db}; | |||
| 354 | my $d=$this->{db}; | |||
| 355 | print "$iam: Creating table '$this->{dbhktbl}' ...\n" if $this->{verbose}; | |||
| 356 | $d->do( | |||
| 357 | "create table if not exists $this->{dbhktbl} (". | |||
| 358 | join(",",map {"@$_"} @coldefs). | |||
| 359 | ")" | |||
| 360 | ); | |||
| 361 | print "$iam: Creating indices on et and utc ...\n" if $this->{verbose}; | |||
| 362 | $d->do("create index if not exists et_ix on $this->{dbhktbl} (et)"); | |||
| 363 | $d->do("create index if not exists utc_ix on $this->{dbhktbl} (utc)"); | |||
| 364 | return $d; | |||
| 365 | } | |||
| 366 | ||||
| 367 | sub hktbl { | |||
| 368 | my $this = shift; | |||
| 369 | return $this->{dbhktbl}; | |||
| 370 | } | |||
| 371 | ||||
| 372 | sub files { | |||
| 373 | my $this = shift; | |||
| 374 | return if ! $this->{files}; | |||
| 375 | return wantarray ? @{$this->{files}} : [@{$this->{files}}]; | |||
| 376 | } | |||
| 377 | ||||
| 378 | sub mnem_tbl_name { | |||
| 379 | my $this = shift; | |||
| 380 | return $this->{mnemonics}; | |||
| 381 | } | |||
| 382 | ||||
| 383 | sub mnem_tbl_rows { | |||
| 384 | my $this = shift; | |||
| 385 | return wantarray ? ($this->{mnem_rows},$this->{mnem_nrows}) : $this->{mnem_rows}; | |||
| 386 | } | |||
| 387 | ||||
| 388 | sub read_files { | |||
| 389 | my $this = shift; | |||
| 390 | my $opts = shift || {}; | |||
| 391 | my $files= $this->files(); | |||
| 392 | ||||
| 393 | die "$err: No files defined.\n" | |||
| 394 | if ! $files; | |||
| 395 | ||||
| 396 | for my $file (@$files) { | |||
| 397 | $this->read_file($file,$opts); | |||
| 398 | } | |||
| 399 | ||||
| 400 | return 1; | |||
| 401 | } | |||
| 402 | ||||
| 403 | sub read_file { | |||
| 404 | my $this = shift; | |||
| 405 | my $opts = @_ && _isopt($_[-1]) ? pop : {}; | |||
| 406 | my $file = shift || $opts->{file}; | |||
| 407 | my $iutc = $opts->{trunc_utc}; # Truncate UTC to secs | |||
| 408 | my $toff = $opts->{toff} || 0; # Does nothing right now | |||
| 409 | my $tmin = $opts->{tmin}; | |||
| 410 | my $tmax = $opts->{tmax}; | |||
| 411 | my $rows = $opts->{rows}; | |||
| 412 | my $load = $opts->{load}; | |||
| 413 | my $load_nrows = $opts->{load_nrows} || 10000; | |||
| 414 | my $print_nrows = $load_nrows/2; | |||
| 415 | my $load_opts = $opts->{load_opts}; | |||
| 416 | my ($z) = $file =~ /\.(gz|zip)$/; | |||
| 417 | my $iam = "$pkg/read"; | |||
| 418 | my $naif = $this->{naif}; | |||
| 419 | $rows = {} if ! $rows && $load; | |||
| 420 | ||||
| 421 | if($tmin) { | |||
| 422 | $tmin = WISE::Time::Str_time($tmin,{z=>1}) or die; | |||
| 423 | } | |||
| 424 | if($tmax) { | |||
| 425 | $tmax = WISE::Time::Str_time($tmax,{z=>1}) or die; | |||
| 426 | } | |||
| 427 | ||||
| 428 | if($load && ! $this->{db}) { | |||
| 429 | $this->init_db(); | |||
| 430 | } | |||
| 431 | ||||
| 432 | print "$iam: Reading".($load?" and loading":"")." '$file' ...\n" | |||
| 433 | if $this->{verbose}; | |||
| 434 | ||||
| 435 | my $fh; | |||
| 436 | if(! $z) { | |||
| 437 | open($fh, "<", $file) | |||
| 438 | or die "$err: Unable to open '$file'; $!.\n"; | |||
| 439 | } else { | |||
| 440 | my $dezcmd = $z eq 'zip' ? 'unzip -p' : 'gzip -dc'; | |||
| 441 | open($fh, "$dezcmd $file |") | |||
| 442 | or die "$err: Unable to open/decompress '$file' with '$dezcmd'; $!.\n"; | |||
| 443 | } | |||
| 444 | ||||
| 445 | my $cols = {}; | |||
| 446 | my $cad = $this->{cadences}{$file} || 0; | |||
| 447 | my $type = $this->{types}{$file} || '-'; | |||
| 448 | my $n = 0; | |||
| 449 | my $nrows = $this->{atrow} || 0; | |||
| 450 | my $nloadrows = 0; | |||
| 451 | my $utc_last = -1; | |||
| 452 | my ($t,$et,$dp); | |||
| 453 | my ($et0,$et1) = ($this->{et0}, $this->{et1}); # Init. start/end times | |||
| 454 | ||||
| 455 | while(<$fh>) { | |||
| 456 | s/[\n\r]+//; # Remove line ending | |||
| 457 | my ($utc,$mnem,$raw,$val) = split /,/; | |||
| 458 | ++$n; | |||
| 459 | next if ! $utc; # Silently skip blank lines | |||
| 460 | die "$err: Malformed line, file '$file', line $.:\n$@" | |||
| 461 | if ! defined $mnem; | |||
| 462 | #$raw //= 0; | |||
| 463 | $val //= $raw; | |||
| 464 | if($mnem =~ m|[-+./]|) { | |||
| 465 | $mnem =~ s|-(?=\d)|_m|og; # Pretty sure the 'o' does nothing | |||
| 466 | $mnem =~ s|\+|_p|og; | |||
| 467 | $mnem =~ s|[-./]|_|og; | |||
| 468 | $mnem =~ s|__+|_|og; | |||
| 469 | } | |||
| 470 | #$mnem = lc $mnem; | |||
| 471 | if($iutc) { | |||
| 472 | $dp //= index($utc,"."); | |||
| 473 | $utc = substr($utc,0,$dp); # Truncated integer time | |||
| 474 | } | |||
| 475 | if($utc ne $utc_last) { | |||
| 476 | $t = WISE::Time::Str_time($utc,{z=>1}); | |||
| 477 | $et= $naif->utc2et($utc); | |||
| 478 | #$t = int($t); | |||
| 479 | } | |||
| 480 | die "$err: Unable to convert UTC '$utc', file '$file', ". | |||
| 481 | "line $.:\n$@" | |||
| 482 | if ! $t; | |||
| 483 | next if $tmin && $t < $tmin; | |||
| 484 | last if $tmax && $t > $tmax; | |||
| 485 | $et0 = $et if ! $et0; | |||
| 486 | $et1 = $et; | |||
| 487 | if(defined wantarray) { | |||
| 488 | # Not void context, so save column data. | |||
| 489 | # Not usually used. | |||
| 490 | push @{$cols->{file}},$file; | |||
| 491 | push @{$cols->{utc}}, $utc; | |||
| 492 | push @{$cols->{t}}, $t; | |||
| 493 | push @{$cols->{et}}, $et; | |||
| 494 | push @{$cols->{mnem}},$mnem; | |||
| 495 | push @{$cols->{raw}}, $raw; | |||
| 496 | push @{$cols->{val}}, $val; | |||
| 497 | } | |||
| 498 | if($rows) { # Save time-indexed row data | |||
| 499 | if($utc ne $utc_last) { | |||
| 500 | ++$nrows; | |||
| 501 | ++$nloadrows if $load; | |||
| 502 | print " $iam: At row $nrows (file row $n) ...\n" | |||
| 503 | if $this->{verbose} && (($nrows-1)%$print_nrows)==0; | |||
| 504 | } | |||
| 505 | if($nloadrows > $load_nrows) { | |||
| 506 | # Load as we go | |||
| 507 | $this->load_rows($rows,$load_opts); | |||
| 508 | $nloadrows = 1 if $load; | |||
| 509 | $rows = { $utc=>{} }; | |||
| 510 | } | |||
| 511 | my $r; # Auxilliary; single row hash | |||
| 512 | $rows->{$utc} ||= {}; # $rows=\%rows; $r=$rows{$utc} | |||
| 513 | $r = $rows->{$utc}; | |||
| 514 | $r->{utc} = $utc; | |||
| 515 | $r->{t} = $t; | |||
| 516 | $r->{et} = $et; | |||
| 517 | $r->{$mnem} = $val; | |||
| 518 | } | |||
| 519 | $utc_last = $utc; | |||
| 520 | } | |||
| 521 | if($load && keys %$rows) { # Leftovers | |||
| 522 | $this->load_rows($rows,$load_opts); | |||
| 523 | } | |||
| 524 | ||||
| 525 | $this->{atrow} = $nrows; | |||
| 526 | ||||
| 527 | $this->{et0} = $et0; | |||
| 528 | $this->{et1} = $et1; | |||
| 529 | ||||
| 530 | return $cols; | |||
| 531 | } | |||
| 532 | ||||
| 533 | sub read_and_load { | |||
| 534 | my $this = shift; | |||
| 535 | my $opts = shift || {}; | |||
| 536 | return $this->read_files({load=>1,%$opts}); | |||
| 537 | } | |||
| 538 | ||||
| 539 | # Load data rows | |||
| 540 | sub load_rows { | |||
| 541 | my $this = shift; | |||
| 542 | my $rows = shift; | |||
| 543 | my $opts = shift || {}; | |||
| 544 | my $d=$this->{db}; | |||
| 545 | my $ttop = time(); | |||
| 546 | my $iam = " $pkg/load"; | |||
| 547 | die "$err/LOAD: DB not open.\n" if ! $d; | |||
| 548 | print "$iam: Loading ".(keys %$rows)." rows ...\n" if $this->{verbose}; | |||
| 549 | # Arrange rows into groups by combinations of mnemonics (columnnames). | |||
| 550 | # This is done because each prepare/execute pair has to work on one | |||
| 551 | # set of columns so the '?' pair properly with values | |||
| 552 | my %groups; | |||
| 553 | for my $utc (keys %$rows) { | |||
| 554 | my $k = join " ", sort keys %{$rows->{$utc}}; | |||
| 555 | push @{$groups{$k}}, $utc; | |||
| 556 | } | |||
| 557 | # For each combination, update the existing row for each utc ... | |||
| 558 | for my $groupkey (keys %groups) { | |||
| 559 | my @utc = sort @{$groups{$groupkey}}; | |||
| 560 | my %utc = map { ($_=>1) } @utc; | |||
| 561 | my %cols = map { ($_ => 1) } split(" ", $groupkey); | |||
| 562 | my @cols = grep {$cols{$_}} map {lc $_->[0]} @coldefs; | |||
| 563 | # print (" cols: @cols \n"); | |||
| 564 | my $sth; | |||
| 565 | print " $iam: New group of ".@utc." ...\n" | |||
| 566 | if $this->{debug}; | |||
| 567 | # Update any rows that already exist | |||
| 568 | $sth = $d->prepare("select utc from $this->{dbhktbl} ". | |||
| 569 | "where utc in ('".join("','",@utc)."')"); | |||
| 570 | $sth->execute(); | |||
| 571 | my $got = $sth->fetchall_arrayref(); | |||
| 572 | if($got && @$got) { | |||
| 573 | print " $iam: Updating ".@utc." ...\n" | |||
| 574 | if $this->{debug}; | |||
| 575 | my $t0 = time(); | |||
| 576 | my @got_utc = sort map { $_->[0] } @$got; | |||
| 577 | my @upd8_cols = @cols; | |||
| 578 | shift @upd8_cols; | |||
| 579 | @utc{@got_utc} = (0) x @got_utc; | |||
| 580 | @utc = grep { $utc{$_} } @utc; # Non-existent subset | |||
| 581 | $sth = $d->prepare("update $this->{dbhktbl} set ". | |||
| 582 | join(",",map {"$_=?"} @upd8_cols)." ". | |||
| 583 | "where utc=?"); | |||
| 584 | my $i = 0; | |||
| 585 | $d->begin_work(); | |||
| 586 | for my $utc (@got_utc) { | |||
| 587 | my $row = $rows->{$utc}; | |||
| 588 | # print (" row: @{$row}{@upd8_cols} \n"); | |||
| 589 | $sth->execute(@{$row}{@upd8_cols},$row->{utc}); | |||
| 590 | if($i>0 && ! ($i%250)) { | |||
| 591 | # Flush | |||
| 592 | $d->commit(); | |||
| 593 | $d->begin_work(); | |||
| 594 | } | |||
| 595 | } | |||
| 596 | # Flush | |||
| 597 | $d->commit(); | |||
| 598 | print " $iam: ... Updated in ".(time()-$t0)." secs.\n" | |||
| 599 | if $this->{debug}; | |||
| 600 | } | |||
| 601 | # Insert new rows | |||
| 602 | if(@utc) { | |||
| 603 | print " $iam: Inserting ".@utc." ...\n" | |||
| 604 | if $this->{debug}; | |||
| 605 | my $t0 = time(); | |||
| 606 | # print ("insert into $this->{dbhktbl} ". | |||
| 607 | # "(".join(",",@cols).") ". | |||
| 608 | # "values (".join(",",('?')x@cols).")"); | |||
| 609 | $sth = $d->prepare("insert into $this->{dbhktbl} ". | |||
| 610 | "(".join(",",@cols).") ". | |||
| 611 | "values (".join(",",('?')x@cols).")"); | |||
| 612 | my $i = 0; | |||
| 613 | $d->begin_work(); | |||
| 614 | for my $utc (sort @utc) { | |||
| 615 | my $row = $rows->{$utc}; | |||
| 616 | # print (" row: $row @{$row}{@cols} \n"); | |||
| 617 | $sth->execute(@{$row}{@cols}); | |||
| 618 | if($i>0 && ! ($i%250)) { | |||
| 619 | # Flush | |||
| 620 | $d->commit(); | |||
| 621 | $d->begin_work(); | |||
| 622 | } | |||
| 623 | } | |||
| 624 | # Flush | |||
| 625 | $d->commit(); | |||
| 626 | print " $iam: ... Inserted in ".(time()-$t0)." secs.\n" | |||
| 627 | if $this->{debug}; | |||
| 628 | } | |||
| 629 | } # Groups | |||
| 630 | print "$iam: Load complete in ".(time()-$ttop)." secs.\n" | |||
| 631 | if $this->{verbose}; | |||
| 632 | ||||
| 633 | return 1; | |||
| 634 | } | |||
| 635 | ||||
| 636 | # Can be called as a class method if mnemfile is provided | |||
| 637 | sub coldefs { | |||
| 638 | my $this = shift; | |||
| 639 | my $mnemfile = shift || $this->{mnemonics}; | |||
| 640 | my $verbose = ref($this) ? $this->{verbose} : 0; | |||
| 641 | my $i = 0; | |||
| 642 | my $iam = "$pkg/col"; | |||
| 643 | ||||
| 644 | if(! @coldefs) { | |||
| 645 | push (@coldefs, ["utc","varchar(20)"]); | |||
| 646 | push (@coldefs, ["t","real"]); | |||
| 647 | push (@coldefs, ["et","real"]); | |||
| 648 | my $ipac = WISE::IPACTbl->new($mnemfile) | |||
| 649 | or die "$err: Unable to open $mnemfile; $!.\n"; | |||
| 650 | $mnem_rows = $ipac->data({hashrow=>1}); | |||
| 651 | $this->{mnem_rows} = $mnem_rows if ref($this); | |||
| 652 | $mnem_nrows = $ipac->nrows(); | |||
| 653 | $this->{mnem_nrows} = $mnem_nrows if ref($this); | |||
| 654 | while ($i < $mnem_nrows) { | |||
| 655 | push @mnem, $mnem_rows->[$i]{mnemonic}; | |||
| 656 | push @coldefs, [$mnem_rows->[$i]{mnemonic},$mnem_rows->[$i]{type}]; | |||
| 657 | $i++; | |||
| 658 | } | |||
| 659 | print "$iam: Loaded $i column definitions from ". | |||
| 660 | "'$this->{mnemonics}' ...\n" | |||
| 661 | if $verbose; | |||
| 662 | } | |||
| 663 | return wantarray ? ([@coldefs],[@mnem],$mnem_rows,$mnem_nrows) : [@coldefs]; | |||
| 664 | } | |||
| 665 | ||||
| 666 | sub mnemonics { | |||
| 667 | my $this = shift; | |||
| 668 | if(! @mnem) { $this->coldefs(); } | |||
| 669 | return [@mnem]; | |||
| 670 | } | |||
| 671 | ||||
| 672 | sub file_ets { | |||
| 673 | my $this = shift; | |||
| 674 | return ($this->{et0},$this->{et1}); | |||
| 675 | } | |||
| 676 | ||||
| 677 | 1 | 2.1e-5 | 2.1e-5 | 1; |