File Coverage

blib/lib/Finance/BeanCounter.pm
Criterion Covered Total %
statement 28 929 3.0
branch 0 528 0.0
condition 0 81 0.0
subroutine 10 56 17.8
pod 0 46 0.0
total 38 1640 2.3


line stmt bran cond sub pod time code
1             #
2             # BeanCounter.pm --- A stock portfolio performance monitoring toolkit
3             #
4             # Copyright (C) 1998 - 2010 Dirk Eddelbuettel
5             #
6             # This program is free software; you can redistribute it and/or modify
7             # it under the terms of the GNU General Public License as published by
8             # the Free Software Foundation; either version 2 of the License, or
9             # (at your option) any later version.
10             #
11             # This program is distributed in the hope that it will be useful,
12             # but WITHOUT ANY WARRANTY; without even the implied warranty of
13             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14             # GNU General Public License for more details.
15             #
16             # You should have received a copy of the GNU General Public License
17             # along with this program; if not, write to the Free Software
18             # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
19              
20             # $Id: BeanCounter.pm,v 1.107 2010/06/13 22:13:09 edd Exp $
21              
22             package Finance::BeanCounter;
23              
24             require strict;
25             require Exporter;
26              
27             #use Carp; # die with info on caller
28 1     1   7161 use Data::Dumper; # debugging aid
  1         10716  
  1         192  
29 1     1   3366 use Date::Manip; # for date parsing
  1         410581  
  1         201  
30 1     1   9562 use DBI; # for the Perl interface to the database
  1         66862  
  1         236  
31 1     1   2246 use English; # friendlier variable names
  1         1273  
  1         8  
32 1     1   53216 use Finance::YahooQuote; # fetch quotes from Yahoo!
  1         163996  
  1         227  
33 1     1   1072 use POSIX qw(strftime); # for date formatting
  1         15255  
  1         17  
34 1     1   2670 use Statistics::Descriptive; # simple statistical functions
  1         23524  
  1         43  
35 1     1   13 use Text::ParseWords; # parse .csv data more reliably
  1         2  
  1         9373  
36              
37             @ISA = qw(Exporter); # make these symbols known
38             @EXPORT = qw(BeanCounterVersion
39             CloseDB
40             ConnectToDb
41             TestInsufficientDatabaseSchema
42             DatabaseDailyData
43             DatabaseHistoricalData
44             DatabaseHistoricalFXData
45             DatabaseHistoricalUBCFX
46             DatabaseHistoricalOandAFX
47             DatabaseInfoData
48             ExistsDailyData
49             ExistsFXDailyData
50             GetTodaysAndPreviousDates
51             GetCashData
52             GetConfig
53             GetDate
54             GetDailyData
55             GetFXData
56             GetFXDatum
57             GetOandAFXData
58             GetUBCFXData
59             GetUBCFXHash
60             GetYahooCurrency
61             GetIsoCurrency
62             GetHistoricalData
63             GetPortfolioData
64             GetPriceData
65             GetRetracementData
66             GetRiskData
67             ParseDailyData
68             ParseNumeric
69             PrintHistoricalData
70             ReportDailyData
71             Sign
72             UpdateDatabase
73             UpdateFXDatabase
74             UpdateFXviaUBC
75             UpdateTimestamp
76             );
77             @EXPORT_OK = qw( );
78             %EXPORT_TAGS = (all => [@EXPORT_OK]);
79              
80             my $VERSION = sprintf("%d.%d", q$Revision: 1.107 $ =~ /(\d+)\.(\d+)/);
81              
82             my %Config; # local copy of configuration hash
83              
84              
85             sub BeanCounterVersion {
86 0     0 0   return $VERSION;
87             }
88              
89              
90             sub ConnectToDb { # log us into the database (PostgreSQL)
91 0     0 0   my $hoststr = '';
92 0 0         $hoststr = "host=$Config{host}"
93             unless (grep(/^$Config{host}$/, ('localhost','127.0.0.1','::1/128')));
94 0           my $dsn = 'dbi:';
95 0 0         if ($Config{odbc}) {
    0          
    0          
    0          
    0          
96 0           $dsn .= "ODBC:$Config{dsn}";
97             } elsif (lc $Config{dbsystem} eq "postgresql") {
98 0           $dsn .= "Pg:dbname=$Config{dbname};${hoststr}";
99             } elsif (lc $Config{dbsystem} eq "mysql") {
100 0           $dsn .= "mysql:dbname=$Config{dbname};${hoststr}";
101             } elsif (lc $Config{dbsystem} eq "sqlite") {
102 0           $dsn .= "SQLite:dbname=$Config{dbname}";
103 0           $Config{user} = '';
104 0           $Config{passwd} = '';
105             } elsif (lc $Config{dbsystem} eq "sqlite2") {
106 0           $dsn .= "SQLite2:dbname=$Config{dbname}";
107 0           $Config{user} = '';
108 0           $Config{passwd} = '';
109             } else {
110 0           die "Database system $Config{dbsystem} is not supported\n";
111             }
112 0           my $dbh = DBI->connect($dsn, $Config{user}, $Config{passwd},
113             { PrintError => $Config{debug},
114             Warn => $Config{verbose},
115             AutoCommit => 0 });
116            
117 0 0         die "No luck with database connection\n" unless ($dbh);
118              
119 0           return $dbh;
120             }
121              
122              
123             sub CloseDB {
124 0     0 0   my $dbh = shift;
125 0 0         $dbh->disconnect or warn $dbh->errstr;
126             }
127              
128              
129             sub ConvertVersionToLargeInteger($) {
130 0     0 0   my ($txt) = @_;
131 0           my ($major,$minor,$revision) = ($txt =~ m/^([0-9]+)\.([0-9]+)\.([0-9]+)$/);
132 0           my $numeric = $major * 1e6 + $minor * 1e3 + $revision;
133             #print "[$txt] -> [$major] [$minor] [$revision] -> $numeric\n";
134 0           return($numeric);
135             }
136              
137              
138             sub TestInsufficientDatabaseSchema($$) {
139 0     0 0   my ($dbh, $required) = @_;
140 0           my @tables = $dbh->tables();
141 0 0         die "Database does not contain table beancounter. " .
142             "Please run 'update_beancounter'.\n" unless grep /beancounter/, @tables;
143 0           my $sql = q{select version from beancounter};
144 0 0         my @res = $dbh->selectrow_array($sql) or die $dbh->errstr;
145 0           my $dbschema = $res[0];
146 0           my $num_required = ConvertVersionToLargeInteger($required);
147 0           my $num_schema = ConvertVersionToLargeInteger($dbschema);
148 0 0         print "Database has schema $dbschema, we require version $required\n"
149             if $Config{debug};
150 0           return ($num_schema < $num_required); # extensive testing was required =:-)
151             }
152              
153              
154             sub GetTodaysAndPreviousDates {
155 0     0 0   my ($date, $prev_date);
156 0           my $today = DateCalc(ParseDate("today"), "- 8 hours");
157              
158             # Depending on whether today is a working day, use today
159             # or the most recent preceding working day
160 0 0         if (Date_IsWorkDay($today)) {
161 0           $date = UnixDate($today, "%Y%m%d");
162 0           $prev_date = UnixDate(DateCalc($today, "- 1 business days"), "%Y%m%d");
163             } else {
164 0           $date = UnixDate(DateCalc($today, "- 1 business days"), "%Y%m%d");
165 0           $prev_date = UnixDate(DateCalc($today, "- 2 business days"), "%Y%m%d");
166             }
167             # override with optional dates, if supplied
168 0 0         $date = UnixDate(ParseDate($main::datearg), "%Y%m%d")
169             if ($main::datearg);
170 0 0         $prev_date = UnixDate(ParseDate($main::prevdatearg),"%Y%m%d")
171             if ($main::prevdatearg);
172              
173             # and create 'prettier' non-ISO 8601 form
174 0           my $pretty_date = UnixDate(ParseDate($date), "%d %b %Y");
175 0           my $pretty_prev_date = UnixDate(ParseDate($prev_date), "%d %b %Y");
176              
177 0           return ($date, $prev_date, $pretty_date, $pretty_prev_date);
178             }
179              
180              
181             sub GetConfig {
182 0     0 0   my ($file, $debug, $verbose, $fx, $extrafx, $updatedate,
183             $dbsystem, $dbname, $fxupdate, $commit, $equityupdate,
184             $ubcfx, $hostarg, $command) = @_;
185              
186 0           %Config = (); # reset hash
187              
188 0           $Config{debug} = $debug; # no debugging as default
189 0           $Config{verbose} = $verbose; # silent == non-verbose as default
190              
191 0           $Config{odbc} = 0; # if 1, use DBI-ODBC, else use DBI-Pg
192              
193 0           $Config{currency} = "USD"; # default to US dollars as domestic currency
194              
195 0           $Config{user} = $ENV{USER}; # default user is current user
196 0           $Config{passwd} = undef; # default password is no password
197              
198 0           $Config{dbsystem} = "PostgreSQL";
199 0           $Config{dbname} = "beancounter";
200              
201 0           $Config{today} = strftime("%Y%m%d", localtime);
202 0           ($Config{lastbizday}, $Config{prevbizday}) = GetTodaysAndPreviousDates;
203              
204             # DSN name for ODBC
205 0           $Config{dsn} = "beancounter"; # default ODBC data source name
206              
207             # default to updating FX
208 0 0         if ($fxupdate) {
209 0           $Config{fxupdate} = 1;
210             } else {
211 0           $Config{fxupdate} = 0;
212             }
213              
214             # default to committing to db
215 0 0         if ($commit) {
216 0           $Config{commit} = 1;
217             } else {
218 0           $Config{commit} = 0;
219             }
220              
221             # default to updateing stocks too
222 0 0         if ($equityupdate) {
223 0           $Config{equityupdate} = 1;
224             } else {
225 0           $Config{equityupdate} = 0;
226             }
227              
228             # default to updateing stocks too
229 0 0         if ($ubcfx) {
230 0           $Config{ubcfx} = 1;
231             } else {
232 0           $Config{ubcfx} = 0;
233             }
234             # pre-load a default host argument
235 0 0         $Config{host} = $hostarg if defined($hostarg);
236              
237 0 0         unless ( -f $file ) {
238 0           warn "Config file $file not found, ignored.\n";
239             } else {
240 0 0         open (FILE, "<$file") or die "Cannot open $file: $!\n";
241 0           while () {
242 0 0         next if (m/(\#|%)/); # ignore comments, if any
243 0 0         next if (m/^\s*$/); # ignore empty lines, if any
244 0 0         if (m/^\s*(\w+)\s*=\s*(.+)\s*$/) {
245 0           $Config{$1} = "$2";
246             }
247             }
248 0           close(FILE);
249             }
250              
251 0 0         $Config{currency} = $fx if defined($fx);
252              
253 0 0         $Config{dbname} = $dbname if defined($dbname);
254 0 0         $Config{dbsystem} = $dbsystem if defined($dbsystem);
255 0 0 0       $Config{odbc} = 1 if defined($dbsystem) and lc $dbsystem eq "odbc";
256              
257             # but allow command-line argument to override
258 0 0 0       $Config{host} = $hostarg
259             if defined($hostarg) and $hostarg ne "localhost";
260              
261              
262 0 0         if (defined($extrafx)) {
263 0 0         unless ($command =~ /^(update|dailyjob)$/) {
264 0           warn "Warning: --extrafx ignored as not updating db\n";
265             } else {
266 0 0         $Config{extrafx} = $extrafx if defined($extrafx);
267             }
268             }
269              
270 0 0         if (defined($updatedate)) { # test the updatedate argument
271 0 0         unless ($command =~ /^(update|dailyjob)$/) {
272 0           warn "Warning: --updatedate ignored as not updating db\n";
273             } else {
274 0 0         die "Error: Invalid date $updatedate for --forceupdate\n"
275             unless (ParseDate($updatedate));
276 0           $Config{updatedate} = UnixDate(ParseDate($updatedate),"%Y%m%d");
277             }
278             }
279              
280 0 0         print Dumper(\%Config) if $Config{debug};
281 0           return %Config;
282             }
283              
284              
285             sub GetCashData {
286 0     0 0   my ($dbh, $date, $res) = @_;
287 0           my ($stmt, $sth, $rv, $ary_ref, $sym_ref, %cash);
288 0           my ($name, $value, $fx, $cost);
289             # get the symbols
290 0           $stmt = "select name, value, currency, cost from cash ";
291 0           $stmt .= "where value > 0 ";
292 0 0 0       $stmt .= "and $res " if ( defined($res)
      0        
293             and $res =~ m/(name|value|currency|cost|owner)/i
294             and not $res =~ m/(symbol|shares|exchange|day)/i
295             );
296 0           $stmt .= "order by name";
297 0 0         print "GetCashData():\n\$stmt = $stmt\n" if $Config{debug};
298              
299 0           $sth = $dbh->prepare($stmt);
300 0           $rv = $sth->execute(); # run query for report end date
301 0           while (($name, $value, $fx, $cost) = $sth->fetchrow_array) {
302 0           $cash{$name}{value} += $value; # adds if there are several
303 0           $cash{$name}{fx} = $fx;
304 0           $cash{$name}{cost} = $cost;
305             }
306 0           $sth->finish();
307 0           return(\%cash);
308             }
309              
310              
311             sub GetDailyData { # use Finance::YahooQuote::getquote
312             # This uses the 'return an entire array' approach of Finance::YahooQuote.
313 0     0 0   my @Args = @_;
314              
315 0 0         if (defined($Config{proxy})) {
316 0           $Finance::YahooQuote::PROXY = $Config{proxy};
317             }
318 0 0 0       if (defined($Config{firewall}) and
      0        
319             $Config{firewall} ne "" and
320             $Config{firewall} =~ m/.*:.*/) {
321 0           my @q = split(':', $Config{firewall}, 2);
322 0           $Finance::YahooQuote::PROXYUSER = $q[0];
323 0           $Finance::YahooQuote::PROXYPASSWD = $q[1];
324             }
325 0 0         if (defined($Config{timeout})) {
326 0 0         $Finance::YahooQuote::TIMEOUT = $Config{timeout} if $Config{timeout};
327             }
328              
329             #my $url = "http://quote.yahoo.com/d" .
330             # "?f=snl1d1t1c1p2va2bapomwerr1dyj1x&s=";
331             #my $array = GetQuote($url,@NA); # get all North American quotes
332 0           my $array = getquote(@Args); # get North American quotes
333 0           my @Res;
334 0           push @Res, (@$array); # and store the entire array of arrays
335 0 0         print Dumper(\@Res) if $Config{debug};
336 0           return @Res;
337             }
338              
339              
340             ## Simple routine to get quotes for an array of arguments
341 1     1   16 BEGIN { use HTTP::Request::Common; }
  1     1   2  
  1         94  
  1         24230  
342             sub GetUBCFXData {
343 0     0 0   my ($symbolsref, $from, $to) = @_;
344              
345 0           my @symbols = @$symbolsref;
346 0           my $nsym = $#symbols + 1;
347              
348 0           my $base = $Config{currency}; # instead of unconditionally requesting USD
349              
350             ## we need the dates as yyyy, mm and dd
351 0           my ($fy,$fm,$fd,$ty,$tm,$td);
352 0           ($fy,$fm,$fd) = ($from =~ m/(\d\d\d\d)(\d\d)(\d\d)/);
353 0           ($ty,$tm,$td) = ($to =~ m/(\d\d\d\d)(\d\d)(\d\d)/);
354              
355             ## build the query URL
356 0           my $url = "http://fx.sauder.ubc.ca/cgi/fxdata?b=$base&";
357 0           $url .= "ld=$td&lm=$tm&ly=$ty&fd=$fd&fm=$fm&fy=$fy&";
358 0           $url .= "daily&q=volume&f=csv&o=T.C";
359 0           $url .= "&c=" . join("&c=", @symbols);
360 0 0         print "Url is $url\n" if $Config{debug};
361              
362 0           my @qr; # results will be collected here
363 0           my $ua = RequestAgent->new;
364 0           $ua->env_proxy; # proxy settings from *_proxy env. variables.
365 0 0         $ua->proxy('http', $PROXY) if defined $PROXY;
366 0 0         $ua->timeout($TIMEOUT) if defined $TIMEOUT;
367              
368 0           foreach (split('\015?\012',$ua->request(GET $url)->content)) {
369             ## skip the commercials / copyrights / attributions
370 0 0         next if $_ =~ m/(PACIFIC|Prof\. Werner Antweiler)/;
371 0 0         print "--> $_\n" if $Config{debug};
372             ## split the csv stream with quotewords() from Text::ParseWords
373 0           my @q = quotewords(',', 0, $_);
374 0           my @fx = splice(@q, -$nsym); # last $nsym are the quotes
375 0           push (@qr, [$q[1], @fx]);
376 0 0         print $q[1], " ", join(" ", @fx), "\n" if $Config{debug};
377             }
378              
379 0           return \@qr;
380             }
381              
382              
383             ## wrapper for single-day hash of currencies
384             sub GetUBCFXHash {
385 0     0 0   my ($symref, $date) = @_;
386              
387 0           my $res = GetUBCFXData($symref, $date, $date);
388              
389 0           my @symbols = @$symref;
390 0           my $nsym = $#symbols + 1;
391            
392             ## format is like
393             ## YYYY/MM/DD CAD/USD GBP/USD
394             ## 2005/01/31 1.2380 0.53087
395             ## so loop over all columns but first
396 0           my %res;
397 0           for (my $i=0; $i<$nsym; $i++) {
398             ## the currency comes as, e.g., CAD/USD so split the CAD part of
399 0           my $cur = (split(/\//, $res->[0]->[$i+1]))[0];
400 0 0         print $cur, "\t" , $res->[1]->[$i+1], "\n" if $Config{debug};
401             ## and value is matching entry in second row
402 0           $res{$cur} = $res->[1]->[$i+1];
403             }
404 0           return \%res; # return the new hash
405             }
406              
407              
408             ## get FX data from OandA.com
409             sub GetOandAFXData {
410 0     0 0   my ($symbol, $from, $to) = @_;
411              
412 0           my $base = $Config{currency}; # instead of unconditionally requesting USD
413              
414             ## we need the dates as yyyy, mm and dd
415 0           my ($fy,$fm,$fd,$ty,$tm,$td);
416 0           ($fy,$fm,$fd) = ($from =~ m/(\d\d\d\d)(\d\d)(\d\d)/);
417 0           ($ty,$tm,$td) = ($to =~ m/(\d\d\d\d)(\d\d)(\d\d)/);
418              
419             ## build the query URL
420 0           my $url = "http://www.oanda.com/convert/fxhistory?lang=en&";
421 0           $url .= "date1=$fm%2F$fd%2F$fy&";
422 0           $url .= "date=$tm%2F$td%2F$ty&date_fmt=us&";
423 0           $url .= "exch=$symbol&exch2=&expr=$Config{currency}&expr2=";
424 0           $url .= "&margin_fixed=0&SUBMIT=Get+Table&format=CSV&redirected=1";
425 0 0         print "Url is $url\n" if $Config{debug};
426              
427 0           my @qr; # results will be collected here
428 0           my $ua = RequestAgent->new;
429 0           $ua->env_proxy; # proxy settings from *_proxy env. variables.
430 0 0         $ua->proxy('http', $PROXY) if defined $PROXY;
431 0 0         $ua->timeout($TIMEOUT) if defined $TIMEOUT;
432              
433 0           my $state = 0;
434 0           foreach (split('\015?\012',$ua->request(GET $url)->content)) {
435 0           my $line = $_;
436 0 0         if ($state == 0) {
437 0 0         if ($_ =~ m|
|) { 
438 0           $state += 1;
439 0           $line =~ s|
||; 
440             }
441             #next;
442             }
443 0 0         if ($state == 1) {
444 0 0         $state += 1 if $_ =~ m||;
445             #next;
446             }
447 0 0         next unless $state == 1;
448             #print "--> $_\n" if $Config{debug};
449             #$state = $_ !~ m||;
450             ## split the csv stream with quotewords() from Text::ParseWords
451             #my @q = quotewords(',', 0, $_);
452             #my @fx = splice(@q, -$nsym); # last $nsym are the quotes
453             #push (@qr, [$q[1], @fx]);
454             #print $q[1], " ", join(" ", @fx), "\n" if $Config{debug};
455              
456 0           push (@qr, $line);
457 0 0         print $line, "\n" if $Config{debug};
458             }
459              
460 0           return \@qr;
461              
462             }
463              
464             sub getIso2YahooCurrencyHashRef() {
465             # map between ISO country codes and Yahoo symbols for the Philly exchange
466 0     0 0   return {"AUD" => "^XAY", # was "^XAD", "AUDUSD=X",
467             "CAD" => "^XCV", # was "^XCD", "CADUSD=X",
468             "CHF" => "^XSY", # was "^XSF", "CHFUSD=X",
469             "EUR" => "^XEU", # was "EURUSD=X",
470             "GBP" => "^XBX", # was "^XBP", "GBPUSD=X",
471             "JPY" => "^XJZ", # was "^XJY", "JPYUSD=X",
472             "USD" => "----"};
473             }
474              
475              
476             sub GetYahooCurrency($) {
477 0     0 0   my ($isoCurrency) = @_;
478 0           my $ref = getIso2YahooCurrencyHashRef();
479 0           return $ref->{$isoCurrency};
480             }
481              
482              
483             sub GetIsoCurrency($) {
484 0     0 0   my ($yahooCurrency) = @_;
485 0           my $ref = getIso2YahooCurrencyHashRef();
486             # Reverse the hash table, ie. yahoo => iso:
487 0           my %yahoo2isoHash = map { $ref->{$_} => $_ } keys(%$ref);
  0            
488 0           return $yahoo2isoHash{$yahooCurrency};
489             }
490              
491              
492             sub GetHistoricalData { # get a batch of historical quotes from Yahoo!
493 0     0 0   my ($symbol,$from,$to) = @_;
494 0           my $ua = RequestAgent->new;
495 0           $ua->env_proxy; # proxy settings from *_proxy env. variables.
496 0 0         $ua->proxy('http', $Config{proxy}) if $Config{proxy}; # or config vars
497 0           my ($a,$b,$c,$d,$e,$f); # we need the date as yyyy, mm and dd
498 0           ($c,$a,$b) = ($from =~ m/(\d\d\d\d)(\d\d)(\d\d)/);
499 0           ($f,$d,$e) = ($to =~ m/(\d\d\d\d)(\d\d)(\d\d)/);
500 0           --$a; --$d; # month is zero-based
  0            
501 0           my $req = new HTTP::Request GET => "http://table.finance.yahoo.com/" .
502             "table.csv?a=$a&b=$b&c=$c&d=$d&e=$e&f=$f&s=$symbol&y=0&g=d&ignore=.csv";
503 0           my $res = $ua->request($req); # Pass request to user agent and get response
504 0 0         if ($res->is_success) { # Check the outcome of the response
505 0           return split(/\n/, $res->content);
506             } else {
507 0           warn "No luck with symbol $symbol\n";
508             }
509             }
510              
511              
512             sub GetPortfolioData {
513 0     0 0   my ($dbh, $res) = @_;
514 0           my ($stmt, $sth);
515              
516             # get the portfolio data
517 0           $stmt = "select symbol, shares, currency, type, owner, cost, date ";
518 0           $stmt .= "from portfolio ";
519 0 0         $stmt .= "where $res" if (defined($res));
520 0 0         print "GetPortfolioData():\n\$stmt = $stmt\n" if $Config{debug};
521              
522 0           $sth = $dbh->prepare($stmt);
523 0           $sth->execute();
524 0           my $data_ref = $sth->fetchall_arrayref({});
525 0           return $data_ref;
526             }
527              
528              
529             sub GetPriceData {
530 0     0 0   my ($dbh, $date, $res) = @_;
531 0           my ($stmt, $sth, $rv, $ary_ref, @symbols, %dates);
532 0           my ($ra, $symbol, $name, $shares, $currency, $price, $prevprice,
533             %prices, %prev_prices, %shares, %fx, %name, %purchdate, %cost,
534             $cost,$pdate,%pricedate);
535              
536             # get the symbols
537 0           $stmt = "select distinct p.symbol from portfolio p, stockinfo s ";
538 0           $stmt .= "where s.symbol = p.symbol and s.active ";
539 0 0         $stmt .= qq{and p.symbol in
540             (select distinct symbol from portfolio where $res)
541             } if (defined($res));
542 0           $stmt .= "order by p.symbol";
543 0 0         print "GetPriceData():\n\$stmt = $stmt\n" if $Config{debug};
544              
545             # get symbols
546 0           @symbols = @{ $dbh->selectcol_arrayref($stmt) };
  0            
547              
548             # for each symbol, get most recent date subject to supplied date
549 0           $stmt = qq{select max(date)
550             from stockprices
551             where symbol = ?
552             and day_close > 0
553             and date <= ?
554             };
555 0 0         print "GetPriceData():\n\$stmt = $stmt\n" if $Config{debug};
556              
557             # for each symbol, get most recent date subject to supplied date:\n";
558 0           foreach $ra (@symbols) {
559 0 0         if (!defined($sth)) {
560 0           $sth = $dbh->prepare($stmt);
561             }
562 0           $rv = $sth->execute($ra, $date); # run query for report end date
563 0           my $res = $sth->fetchrow_array;
564 0           $dates{$ra} = $res;
565 0 0         $sth->finish() if $Config{odbc};
566             }
567              
568             #sum(p.shares*p.cost)/sum(p.shares) as p.cost,
569             # now get closing price etc at date
570 0           $stmt = qq{select i.symbol, i.name, p.shares, p.currency,
571             d.day_close,
572             p.cost,
573             p.date,
574             d.previous_close
575             from stockinfo i, portfolio p, stockprices d
576             where d.symbol = p.symbol
577             and i.symbol = d.symbol
578             and d.date = ?
579             and d.symbol = ?
580             };
581              
582             #### TWA, 2003-12-04
583             ## According to the original code, here the restriction applies to the
584             ## portfolio table only. But _note_:
585             ## the same restriction is used in GetRiskData() !!!!
586             ## the same restriction is used in GetRetracementData() !!!!
587             ## But it is not enough to restrict the symbols used by the sub-select
588             ## command. One has to restrict the main selection with the same
589             ## restriction rules.
590             ## Thus, make a copy of the restriction and replace the column names
591             ## to a syntax to use the portfolio table only.
592 0 0         if (defined($res)) {
593             ## avoid name space pollution
594 0           my $portfolio_restriction = $res;
595              
596 0           $portfolio_restriction =~ s/\bsymbol\b/p\.symbol/g;
597 0           $portfolio_restriction =~ s/\bshares\b/p\.shares/g;
598 0           $portfolio_restriction =~ s/\bcurrency\b/p\.currency/g;
599 0           $portfolio_restriction =~ s/\btype\b/p\.type/g;
600 0           $portfolio_restriction =~ s/\bowner\b/p\.owner/g;
601 0           $portfolio_restriction =~ s/\bcost\b/p\.cost/g;
602 0           $portfolio_restriction =~ s/\bdate\b/p\.date/g;
603              
604 0           $stmt .= qq{ and $portfolio_restriction }
605             } # end if (defined($res))
606              
607 0 0         $stmt .= qq{ and d.symbol in
608             (select distinct symbol from portfolio where $res)
609             } if (defined($res));
610             ## $stmt .= qq{ group by i.symbol,i.name,p.shares,p.currency,d.day_close,p.date,d.previous_close };
611              
612             #select symbol, avg('today'-date) as days, sum(shares*cost)/sum(shares) as cost, sum(shares) as size, sum(shares*cost) as pos from portfolio where owner!='peter' group by symbol order by days desc;
613 0 0         print "GetPriceData():\n\$stmt = $stmt\n" if $Config{debug};
614              
615             # now get closing price etc at date
616 0           $sth = undef;
617 0           my $i = 0;
618 0           foreach $ra (@symbols) {
619 0 0         if (!defined($sth)) {
620 0           $sth = $dbh->prepare($stmt);
621             }
622 0           $rv = $sth->execute($dates{$ra}, $ra);
623 0           while (($symbol, $name, $shares, $currency, $price,
624             $cost, $pdate, $prevprice) = $sth->fetchrow_array) {
625 0 0 0       print join " ", ($symbol, $name, $shares,
      0        
      0        
626             $currency, $price,
627             $cost||"NA", $pdate||"NA",
628             $prevprice||"NA"), "\n" if $Config{debug};
629 0           $fx{$name} = $currency;
630 0           $prices{$name} = $price;
631 0           $pricedate{$name} = $dates{$symbol};
632 0           $cost{$name} = $cost;
633 0           $purchdate{$name} = $pdate;
634 0           $prev_prices{$name} = $prevprice;
635 0           $name .= ":$i";
636 0           $i++;
637 0           $shares{$name} = $shares;
638 0           $purchdate{$name} = $pdate; # also store purchuse date on non-aggregate entry
639 0           $cost{$name} = $cost; # also store purchuse cost on non-aggregate entry
640             }
641 0           $sth->finish;
642             }
643              
644 0 0         print Dumper(\%prices) if $Config{debug};
645 0 0         print Dumper(\%prev_prices) if $Config{debug};
646 0 0         print Dumper(\%shares) if $Config{debug};
647              
648 0           return (\%fx, \%prices, \%prev_prices, \%shares, \%pricedate,
649             \%cost, \%purchdate);
650             }
651              
652              
653             sub GetFXData {
654 0     0 0   my ($dbh, $date, $fx) = @_;
655             ## find FX data from closest date smaller or equal to the requested date
656              
657             # for each symbol, get most recent date subject to supplied date
658 0           my $stmt = qq{select max(date)
659             from fxprices
660             where currency = ?
661             and date <= ?
662             };
663 0 0         print "GetFXData():\n\$stmt = $stmt\n" if $Config{debug};
664              
665             # get most recent date subject to supplied date
666 0           my %fxdates;
667             my $sth;
668 0           foreach my $fxval (sort values %$fx) {
669 0 0         next if $fxval eq $Config{currency};# skip user's default currency
670 0 0         if (!defined($sth)) {
671 0           $sth = $dbh->prepare($stmt);
672             }
673 0           $rv = $sth->execute($fxval, $date); # run query for report end date
674 0           my $res = $sth->fetchrow_array;
675 0           $fxdates{$fxval} = $res;
676 0 0         $sth->finish() if $Config{odbc};
677             }
678              
679 0           $stmt = qq{ select day_close, previous_close from fxprices
680             where date = ?
681             and currency = ?
682             };
683 0 0         print "GetFXData():\n\$stmt = $stmt\n" if $Config{debug};
684              
685 0           $sth = undef;
686 0           my (%fx_prices,%prev_fx_prices);
687 0           foreach my $fxval (sort values %$fx) {
688 0 0         if ($fxval eq $Config{currency}) {
689 0           $fx_prices{$fxval} = 1.0;
690 0           $prev_fx_prices{$fxval} = 1.0;
691             } else {
692 0 0         if (!defined($sth)) {
693 0           $sth = $dbh->prepare($stmt);
694             }
695 0           $sth->execute($fxdates{$fxval}, $fxval); # run query for FX cross
696 0 0         my ($val, $prevval) = $sth->fetchrow_array
697             or die "Found no $fxval for $date in the beancounter database.\n " .
698             "Use the --date and/or --prevdate options to pick another date.\n";
699 0           $fx_prices{$fxval} = $val;
700 0           $prev_fx_prices{$fxval} = $prevval;
701 0 0         if (Date_Cmp(ParseDate($fxdates{$fxval}), ParseDate($date)) !=0) {
702 0 0         print "Used FX date $fxdates{$fxval} instead of $date\n"
703             if $Config{verbose};
704             }
705 0           my $ary_ref = $sth->fetchall_arrayref;
706             }
707             }
708 0           return (\%fx_prices, \%prev_fx_prices);
709             }
710              
711             ## simple wrapper for GetFXDate for single currency + date
712             sub GetFXDatum {
713 0     0 0   my ($dbh, $date, $fx) = @_;
714              
715 0           my %fxhash;
716 0           $fxhash{foo} = $fx;
717 0           my ($fxcurrent) = GetFXData($dbh, $date, \%fxhash);
718 0           return $fxcurrent->{$fx};
719             }
720              
721             ## NB no longer used as we employ Finance::YahooQuote directly
722             sub GetQuote { # taken from Dj's Finance::YahooQuote
723 0     0 0   my ($URL,@symbols) = @_; # and modified to allow for different URL
724 0           my ($x,@q,@qr,$ua,$url); # and the simple filtering below as well
725             # the firewall code below
726 0 0         if (defined($Config{proxy})) {
727 0           $Finance::YahooQuote::PROXY = $Config{proxy};
728             }
729 0 0 0       if (defined($Config{firewall}) and
      0        
730             $Config{firewall} ne "" and
731             $Config{firewall} =~ m/.*:.*/) {
732 0           my @q = split(':', $Config{firewall}, 2);
733 0           $Finance::YahooQuote::PROXYUSER = $q[0];
734 0           $Finance::YahooQuote::PROXYPASSWD = $q[1];
735             }
736 0 0         if (defined($Config{timeout})) {
737 0 0         $Finance::YahooQuote::TIMEOUT = $Config{timeout} if $Config{timeout};
738             }
739              
740 0           undef @qr; # reset result structure
741 0           while (scalar(@symbols) > 0) {# while we have symbols to query
742 0           my (@symbols_100); # Peter Kim's patch to batch 100 at a time
743 0 0         if (scalar(@symbols)>=100) {# if more than hundred symbols left
744 0           @symbols_100 = splice(@symbols,0,100); # then skim the first 100 off
745             } else { # otherwise
746 0           @symbols_100 = @symbols; # take what's left
747 0           @symbols = (); # and show we're done
748             }
749              
750 0           my $array = getquote(@symbols_100); # get quotes using Finance::YahooQ.
751 0           push(@qr,[@array]); # and store result as anon array
752              
753             }
754 0           return \@qr; # return a pointer to the results array
755             }
756              
757              
758             sub GetRetracementData {
759 0     0 0   my ($dbh,$date,$prevdate,$res,$fx_prices) = @_;
760              
761 0           my (%high52, %highprev, %low52, %lowprev);
762              
763             # get the symbols
764 0           my $stmt = qq{select distinct p.symbol, i.name, p.shares, p.date
765             from portfolio p, stockinfo i
766             where p.symbol = i.symbol
767             and i.active };
768              
769             #### TWA, 2003-12-07
770             ## According to the original code, here the restriction applies to the
771             ## portfolio table only. But _note_:
772             ## the same restriction is used in GetPriceData() !!!!
773             ## But it is not enough to restrict the symbols used by the sub-select
774             ## command. One has to restrict the main selection with the same
775             ## restriction rules.
776             ## Thus, make a copy of the restriction and replace the column names
777             ## to a syntax to use the portfolio table only.
778 0 0         if (defined($res)) {
779             ## avoid name space pollution
780 0           my $portfolio_restriction = $res;
781              
782 0           $portfolio_restriction =~ s/\bsymbol\b/p\.symbol/g;
783 0           $portfolio_restriction =~ s/\bshares\b/p\.shares/g;
784 0           $portfolio_restriction =~ s/\bcurrency\b/p\.currency/g;
785 0           $portfolio_restriction =~ s/\btype\b/p\.type/g;
786 0           $portfolio_restriction =~ s/\bowner\b/p\.owner/g;
787 0           $portfolio_restriction =~ s/\bcost\b/p\.cost/g;
788 0           $portfolio_restriction =~ s/\bdate\b/p\.date/g;
789              
790 0           $stmt .= qq{ and $portfolio_restriction }
791             } # end if (defined($res))
792              
793 0 0         $stmt .= qq{and p.symbol in
794             (select distinct symbol from portfolio where $res)
795             } if (defined($res));
796 0           $stmt .= "order by p.symbol";
797              
798 0 0         print "GetRetracementData():\n\$stmt = $stmt\n" if $Config{debug};
799              
800 0           my $sth = $dbh->prepare($stmt);
801 0           my $rv = $sth->execute(); # run query for report end date
802 0           my $sref = $sth->fetchall_arrayref;
803              
804             # # get static 52max from stockinfo
805             # $stmt = qq{select high_52weeks, low_52weeks
806             # from stockinfo where symbol = ?};
807             # $sth = $dbh->prepare($stmt);
808             # foreach my $ra (@$sref) {
809             # $rv = $sth->execute($ra->[0]);
810             # my @res = $sth->fetchrow_array; # get data
811             # $high52{$ra->[1]} = $res[0];
812             # $low52{$ra->[1]} = $res[1];
813             # }
814              
815             # get max/min over prevate .. date period
816 0           $stmt = qq{select day_close
817             from stockprices
818             where symbol = ?
819             and date <= ?
820             and date >= ?
821             and day_close > 0
822             order by date
823             };
824              
825 0 0         print "GetRetracementData():\n\$stmt = $stmt\n" if $Config{debug};
826              
827 0           $sth = $dbh->prepare($stmt);
828 0           foreach my $ra (@$sref) {
829 0           my $refdate = $prevdate; # start from previous date
830 0 0         if (defined($ra->[3])) { # if startdate in DB
831             ## then use it is later then the $prevdate
832 0 0         $refdate = $ra->[3] if (Date_Cmp($prevdate, $ra->[3]) < 0)
833             }
834 0           $rv = $sth->execute($ra->[0], $date, $refdate);
835 0           my $dref = $sth->fetchall_arrayref; # get data
836 0           my $x = Statistics::Descriptive::Full->new();
837 0           for (my $i=0; $i
  0            
838 0           $x->add_data($dref->[$i][0]); # add prices
839             }
840 0           $highprev{$ra->[1]} = $x->max();
841 0           $lowprev{$ra->[1]} = $x->min();
842             }
843              
844             # return (\%high52, \%highprev, \%low52, \%lowprev);
845 0           return (\%highprev, \%lowprev);
846             }
847              
848              
849             sub GetRiskData {
850 0     0 0   my ($dbh,$date,$prevdate,$res,$fx_prices,$crit) = @_;
851              
852             # get the symbols
853 0           my $stmt = qq{select distinct p.symbol, i.name
854             from portfolio p, stockinfo i
855             where p.symbol = i.symbol
856             and i.active };
857              
858             #### TWA, 2003-12-07
859             ## According to the original code, here the restriction applies to the
860             ## portfolio table only. But _note_:
861             ## the same restriction is used in GetPriceData() !!!!
862             ## But it is not enough to restrict the symbols used by the sub-select
863             ## command. One has to restrict the main selection with the same
864             ## restriction rules.
865             ## Thus, make a copy of the restriction and replace the column names
866             ## to a syntax to use the portfolio table only.
867 0 0         if (defined($res)) {
868             ## avoid name space pollution
869 0           my $portfolio_restriction = $res;
870              
871 0           $portfolio_restriction =~ s/\bsymbol\b/p\.symbol/g;
872 0           $portfolio_restriction =~ s/\bshares\b/p\.shares/g;
873 0           $portfolio_restriction =~ s/\bcurrency\b/p\.currency/g;
874 0           $portfolio_restriction =~ s/\btype\b/p\.type/g;
875 0           $portfolio_restriction =~ s/\bowner\b/p\.owner/g;
876 0           $portfolio_restriction =~ s/\bcost\b/p\.cost/g;
877 0           $portfolio_restriction =~ s/\bdate\b/p\.date/g;
878              
879 0           $stmt .= qq{ and $portfolio_restriction }
880             } # end if (defined($res))
881              
882 0 0         $stmt .= qq{and p.symbol in
883             (select distinct symbol from portfolio where $res)
884             } if (defined($res));
885 0           $stmt .= "order by p.symbol";
886              
887 0 0         print "GetRiskData():\n\$stmt = $stmt\n" if $Config{debug};
888              
889 0           my $sth = $dbh->prepare($stmt);
890 0           my $rv = $sth->execute(); # run query for report end date
891 0           my $sref = $sth->fetchall_arrayref;
892              
893             # compute volatility
894 0           $stmt = qq{select day_close
895             from stockprices
896             where symbol = ?
897             and date <= ?
898             and date >= ?
899             and day_close > 0
900             order by date
901             };
902              
903 0 0         print "GetRiskData():\n\$stmt = $stmt\n" if $Config{debug};
904              
905 0           $sth = $dbh->prepare($stmt);
906 0           my (%vol, %quintile);
907 0           foreach my $ra (@$sref) {
908 0           $rv = $sth->execute($ra->[0], $date, $prevdate);
909 0           my $dref = $sth->fetchall_arrayref; # get data
910 0           my $x = Statistics::Descriptive::Full->new();
911 0           for (my $i=1; $i
  0            
912 0           $x->add_data($dref->[$i][0]/$dref->[$i-1][0] - 1);
913             }
914 0 0         printf("%16s: stdev %6.2f min %6.2f max %6.2f\n",
915             $ra->[1], $x->standard_deviation, $x->min, $x->max)
916             if $Config{debug};
917 0           $vol{$ra->[1]} = $x->standard_deviation;
918 0 0         if ($x->count() < 100) {
919 0 0         print "$ra->[1]: Only ", $x->count(), " data points, ",
920             "need at least 100 for percentile calculation\n" if $Config{debug};
921 0           $quintile{$ra->[1]} = undef;
922             } else {
923 0           $quintile{$ra->[1]} = $x->percentile(1);
924             }
925             }
926              
927             # compute correlations via OLS regression
928 0           $stmt = qq{select a.day_close, b.day_close
929             from stockprices a, stockprices b
930             where a.symbol = ? and b.symbol = ?
931             and a.date <= ? and a.date >= ?
932             and a.date = b.date
933             and a.day_close != 0
934             and b.day_close != 0
935             order by a.date
936             };
937              
938 0 0         print "GetRiskData():\n\$stmt = $stmt\n" if $Config{debug};
939              
940 0           $sth = $dbh->prepare($stmt);
941 0           my %cor;
942 0           foreach my $ra (@$sref) {
943 0           foreach my $rb (@$sref) {
944 0           my $res = $ra->[0] cmp $rb->[0];
945 0 0         if ($res < 0) {
    0          
946 0           $rv = $sth->execute($ra->[0], $rb->[0], $date, $prevdate);
947 0           my $dref = $sth->fetchall_arrayref; # get data
948 0           my $x = Statistics::Descriptive::Full->new();
949 0           my $y = Statistics::Descriptive::Full->new();
950 0           for (my $i=1; $i
  0            
951 0           $x->add_data($dref->[$i][0]/$dref->[$i-1][0] - 1);
952 0           $y->add_data($dref->[$i][1]/$dref->[$i-1][1] - 1);
953             }
954 0           my @arr = $x->least_squares_fit($y->get_data());
955 0           my $rho = $arr[2];
956 0 0         unless (defined($rho)) {
957 0           warn "No computable correlation between $ra->[1] and $rb->[1];"
958             . " set to 0\n";
959 0           $rho = 0.0;
960             }
961 0           $cor{$ra->[1]}{$rb->[1]} = $rho;
962 0 0         printf("%6s %6s correlation %6.4f\n",
963             $ra->[1], $rb->[1], $arr[2]) if $Config{debug};
964             } elsif ($res > 0) {
965 0           $cor{$ra->[1]}{$rb->[1]} = $cor{$rb->[1]}{$ra->[1]};
966             } else {
967 0           $cor{$ra->[1]}{$rb->[1]} = 1;
968             }
969             }
970             }
971              
972             # for each symbol, get most recent date subject to supplied date
973 0           my %maxdate;
974 0           $stmt = qq{select max(date)
975             from stockprices
976             where symbol = ?
977             and date <= ?
978             };
979              
980 0 0         print "GetRiskData():\n\$stmt = $stmt\n" if $Config{debug};
981              
982 0           $sth = $dbh->prepare($stmt);
983 0           foreach my $ra (@$sref) {
984 0           $rv = $sth->execute($ra->[0], $date); # run query for report end date
985 0           my $res = $sth->fetchrow_array;
986 0           $maxdate{$ra->[1]} = $res;
987 0 0         $sth->finish() if $Config{odbc};
988             }
989              
990             # get position values
991 0           my (%pos, $possum);
992 0           $stmt = qq{select p.shares, d.day_close, p.currency
993             from portfolio p, stockprices d, stockinfo i
994             where d.symbol = p.symbol
995             and d.symbol = i.symbol
996             and d.date = ?
997             and d.symbol = ?
998             };
999 0 0         $stmt .= qq{and d.symbol in
1000             (select distinct symbol from portfolio where $res)
1001             } if (defined($res));
1002              
1003 0 0         print "GetRiskData():\n\$stmt = $stmt\n" if $Config{debug};
1004              
1005 0           $sth = $dbh->prepare($stmt);
1006 0           foreach my $ra (@$sref) {
1007 0           $rv = $sth->execute($maxdate{$ra->[1]}, $ra->[0]);
1008 0           while (my ($shares, $price, $fx) = $sth->fetchrow_array) {
1009 0 0         print "$ra->[1] $shares $price\n" if $Config{debug};
1010 0           my $amount = $shares * $price *
1011             $fx_prices->{$fx} / $fx_prices->{$Config{currency}};
1012 0           $pos{$ra->[1]} += $amount;
1013             }
1014             }
1015              
1016             # aggregate risk:
1017             # VaR is z_crit * sqrt(horizon) * sqrt (X.transpose * Sigma * X)
1018             # where X is position value vector and Sigma the covariance matrix
1019             # given that Perl is not exactly a language for matrix calculus (as
1020             # eg GNU Octave), we flatten the computation into a double loop
1021 0           my $sum = 0;
1022 0           foreach my $pkey (keys %pos) {
1023 0 0 0       if (defined($pos{$pkey}) && defined($vol{$pkey})) {
1024 0           foreach my $vkey (keys %vol) {
1025 0 0 0       if (defined($pos{$vkey}) && defined($vol{$vkey}) &&
      0        
1026             defined($cor{$vkey}{$pkey})) {
1027 0           $sum += $pos{$pkey} * $pos{$vkey} * $vol{$vkey} * $vol{$pkey} *
1028             $cor{$vkey}{$pkey};
1029             }
1030             }
1031             }
1032             }
1033 0           my $var = $crit * sqrt($sum);
1034              
1035              
1036             ## marginal var
1037 0           my %margvar;
1038 0           foreach my $outer (keys %pos) {
1039 0           my $saved = $pos{$outer};
1040 0           my $sum = 0;
1041 0           $pos{$outer} = 0;
1042 0           foreach my $pkey (keys %pos) {
1043 0 0 0       if (defined($pos{$pkey}) && defined($vol{$pkey})) {
1044 0           foreach my $vkey (keys %vol) {
1045 0 0 0       if (defined($pos{$vkey}) && defined($vol{$vkey}) &&
      0        
1046             defined($cor{$vkey}{$pkey})) {
1047 0           $sum += $pos{$pkey} * $pos{$vkey} * $vol{$vkey} * $vol{$pkey}
1048             * $cor{$vkey}{$pkey};
1049             }
1050             }
1051             }
1052             }
1053 0           $margvar{$outer} = $crit * sqrt($sum) - $var;
1054 0           $pos{$outer} = $saved;
1055             }
1056              
1057 0           return ($var, \%pos, \%vol, \%quintile, \%margvar);
1058             }
1059              
1060              
1061             sub DatabaseDailyData { # a row to the dailydata table
1062 0     0 0   my ($dbh, %hash) = @_;
1063 0           my @cols = ('previous_close', 'day_open', 'day_high', 'day_low',
1064             'day_close', 'day_change', 'bid', 'ask', 'volume');
1065 0           my @updTerms = ();
1066 0           foreach my $col (@cols) {
1067 0           push(@updTerms, "$col = ?");
1068             }
1069 0           my $updStmt = 'update stockprices set ' . join(', ', @updTerms) .
1070             ' where symbol = ? and date = ?';
1071 0 0         print "$updStmt\n" if $Config{debug};
1072 0           my $updSth;
1073              
1074 0           push(@cols, 'symbol', 'date');
1075 0           my @insTerms = ();
1076 0           foreach my $col (@cols) {
1077 0           push(@insTerms, '?');
1078             }
1079 0           my $insStmt = 'insert into stockprices (' . join(', ', @cols) .
1080             ') values (' . join(', ', @insTerms) . ')';
1081 0 0         print "$insStmt\n" if $Config{debug};
1082 0           my $insSth;
1083            
1084 0           foreach my $key (keys %hash) { # now split these into reference to the arrays
1085 0 0         print "$hash{$key}{symbol} " if $Config{verbose};
1086              
1087 0 0         if ($hash{$key}{date} eq "N/A") {
1088 0 0         warn "Not databasing $hash{$key}{symbol}\n" if $Config{debug};
1089 0           next;
1090             }
1091              
1092 0 0         if (ExistsDailyData($dbh, %{$hash{$key}})) {
  0            
1093 0           my @vals = ();
1094 0           foreach my $col (@cols) {
1095 0 0         if ($hash{$key}{$col} =~ m/^\s*N\/A\s*$/) {
1096 0           push(@vals, undef);
1097             } else {
1098 0           push(@vals, $hash{$key}{$col});
1099             }
1100             }
1101 0 0         if ($Config{commit}) {
1102 0 0         if (!defined($updSth)) {
1103 0 0         $updSth = $dbh->prepare($updStmt) or die $dbh->errstr;
1104             }
1105 0 0 0       $updSth->execute(@vals)
1106             and $updSth->finish()
1107             or warn $dbh->errstr . "Update failed for " .
1108             "$hash{$key}{symbol} with [$updStmt]\n";
1109             }
1110             }
1111             else {
1112 0           my @vals = ();
1113 0           foreach my $col (@cols) {
1114 0 0         if ($hash{$key}{$col} =~ m/^\s*N\/A\s*$/) {
1115 0           push(@vals, undef);
1116             } else {
1117 0           push(@vals, $hash{$key}{$col});
1118             }
1119             }
1120 0 0         if ($Config{commit}) {
1121 0 0         if (!defined($insSth)) {
1122 0 0         $insSth = $dbh->prepare($insStmt) or die $dbh->errstr;
1123             }
1124 0 0 0       $insSth->execute(@vals)
1125             and $insSth->finish()
1126             or warn $dbh->errstr . "Insert failed for " .
1127             "$hash{$key}{symbol} with [$insStmt]\n";
1128             }
1129             }
1130             }
1131 0 0         $dbh->commit() if $Config{commit};
1132             }
1133              
1134              
1135             sub DatabaseFXDailyData {
1136 0     0 0   my ($dbh, %hash) = @_;
1137 0           foreach my $key (keys %hash) { # now split these into reference to the arrays
1138 0 0         if ($key eq "") {
1139 0 0         print "Empty key in DatabaseFXDailyData, skipping\n" if $Config{debug};
1140 0           next;
1141             }
1142 0           my $fx = GetIsoCurrency($hash{$key}{symbol});
1143 0 0         print "$fx ($hash{$key}{symbol}) " if $Config{debug};
1144 0 0         if (ExistsFXDailyData($dbh, $fx, %{$hash{$key}})) {
  0            
1145             # different sequence of parameters, see SQL statement above!
1146 0           my $stmt = qq{update fxprices
1147             set previous_close = ?,
1148             day_open = ?,
1149             day_low = ?,
1150             day_high = ?,
1151             day_close = ?,
1152             day_change = ?
1153             where currency = ?
1154             and date = ?
1155             };
1156              
1157 0 0         print "DatabaseFXDailyData():\n\$stmt = $stmt\n" if $Config{debug};
1158 0 0         print "DatabaseFXDailyData(): $hash{$key}{previous_close},
1159             $hash{$key}{day_open}, $hash{$key}{day_low}, $hash{$key}{day_high},
1160             $hash{$key}{day_close}, $hash{$key}{day_change},
1161             $fx, $hash{$key}{date} \n" if $Config{debug};
1162              
1163 0 0         if ($Config{commit}) {
1164 0 0         $dbh->do($stmt, undef, $hash{$key}{previous_close},
1165             $hash{$key}{day_open},
1166             $hash{$key}{day_low},
1167             $hash{$key}{day_high},
1168             $hash{$key}{day_close},
1169             $hash{$key}{day_change},
1170             $fx,
1171             $hash{$key}{date}
1172             )
1173             or warn "Failed for $fx at $hash{$key}{date}\n";
1174             }
1175              
1176             ## Alternate FX using the EURUSD=X quotes which don;t have history
1177             # my $stmt = qq{update fxprices
1178             # set day_close = ?
1179             # where currency = ?
1180             # and date = ?
1181             # };
1182              
1183             # print "DatabaseFXDailyData():\n\$stmt = $stmt\n" if $Config{debug};
1184             # print "DatabaseFXDailyData(): ",
1185             # "$hash{$key}{day_close}, $fx, $hash{$key}{date} \n" if $Config{debug};
1186              
1187             # if ($Config{commit}) {
1188             # $dbh->do($stmt, undef,
1189             # $hash{$key}{day_close},
1190             # $fx,
1191             # $hash{$key}{date}
1192             # )
1193             # or warn "Failed for $fx at $hash{$key}{date}\n";
1194             # }
1195             } else {
1196 0           my $stmt = qq{insert into fxprices values (?, ?, ?, ?, ?, ?, ?, ?);};
1197              
1198 0 0         print "DatabaseFXDailyData():\n\$stmt = $stmt\n" if $Config{debug};
1199 0 0         print "DatabaseFXDailyData(): $fx, $hash{$key}{date},
1200             $hash{$key}{previous_close},
1201             $hash{$key}{day_open}, $hash{$key}{day_low}, $hash{$key}{day_high},
1202             $hash{$key}{day_close}, $hash{$key}{day_change},
1203             \n" if $Config{debug};
1204              
1205 0 0         if ($Config{commit}) {
1206 0           my $sth = $dbh->prepare($stmt);
1207 0 0         $sth->execute($fx,
1208             $hash{$key}{date},
1209             $hash{$key}{previous_close},
1210             $hash{$key}{day_open},
1211             $hash{$key}{day_low},
1212             $hash{$key}{day_high},
1213             $hash{$key}{day_close},
1214             $hash{$key}{day_change}
1215             )
1216             or warn "Failed for $fx at $hash{$key}{date}\n";
1217             }
1218              
1219             ## Alternate FX using the EURUSD=X quotes which don;t have history
1220             # my $stmt = qq{insert into fxprices values (?, ?, ?, ?, ?, ?, ?, ?);};
1221              
1222             # print "DatabaseFXDailyData():\n\$stmt = $stmt\n" if $Config{debug};
1223             # print "DatabaseFXDailyData(): $fx, $hash{$key}{date},",
1224             # "$hash{$key}{day_close}\n" if $Config{debug};
1225              
1226             # if ($Config{commit}) {
1227             # my $sth = $dbh->prepare($stmt);
1228             # $sth->execute($fx, $hash{$key}{date},
1229             # undef, undef, undef, undef,
1230             # $hash{$key}{day_close}, undef
1231             # )
1232             # or warn "Failed for $fx at $hash{$key}{date}\n";
1233             # }
1234             }
1235 0 0         if ($Config{commit}) {
1236 0           $dbh->commit();
1237             }
1238             }
1239             }
1240              
1241              
1242             sub DatabaseHistoricalData {
1243 0     0 0   my ($dbh, $symbol, @res) = @_;
1244 0           $symbol = uc $symbol; # make sure symbols are uppercase'd
1245              
1246 0           my %data = (symbol => $symbol,
1247             date => undef,
1248             day_open => undef,
1249             day_high => undef,
1250             day_low => undef,
1251             day_close => undef,
1252             volume => undef);
1253              
1254 0           my @colNames = sort(keys(%data));
1255 0           my @colRepl = ();
1256 0           my @updTerms = ();
1257 0           foreach my $col (@colNames) {
1258 0           push(@colRepl, '?');
1259 0 0 0       next if ($col eq 'symbol' || $col eq 'date');
1260 0           push(@updTerms, "$col = ?");
1261             }
1262              
1263 0           my $insStmt = 'insert into stockprices (' . join(', ', @colNames) .
1264             ') values (' . join(', ', @colRepl) . ')';
1265 0           my $insSth;
1266 0           my $updStmt = 'update stockprices set ' . join(', ', @updTerms) .
1267             ' where symbol = ? and date = ?';
1268 0           my $updSth;
1269 0 0         print "DatabaseHistoricalData: insStmt is \"$insStmt\"\n" if $Config{debug};
1270 0 0         print "DatabaseHistoricalData: updStmt is \"$updStmt\"\n" if $Config{debug};
1271            
1272 0           foreach my $line (@res) { # loop over all supplied symbols
1273 0 0         next if !defined($line);
1274 0           ($data{date}, $data{day_open}, $data{day_high},
1275             $data{day_low}, $data{day_close}, $data{volume},
1276             $data{adjclose}) = split(/\,/, $line);
1277 0           $data{date} = GetDate($data{date});
1278 0 0         if (defined($data{date})) {
1279             # If close was not supplied, we assume a mutual fund.
1280             # So let close be open.
1281 0 0 0       if (!defined($data{day_close})) {
    0 0        
1282 0           $data{day_close} = $data{day_open};
1283 0           $data{day_open} = undef;
1284             }
1285             elsif (defined($data{adjclose}) &&
1286             $data{adjclose} != $data{day_close} &&
1287             $data{day_close} != 0) { # process split adjustment factor
1288 0           my $split_adj = $data{adjclose} / $data{day_close};
1289 0           $data{day_open} *= $split_adj;
1290 0           $data{day_high} *= $split_adj;
1291 0           $data{day_low} *= $split_adj;
1292 0           $data{day_close} = $data{adjclose};
1293             }
1294              
1295 0 0         if (ExistsDailyData($dbh, %data)) {
1296 0           my @colVals = ();
1297 0           foreach my $col (@colNames) {
1298 0 0 0       next if ($col eq 'symbol' || $col eq 'date');
1299 0 0         $data{$col} = 'NULL' if !defined($data{$col});
1300 0           push(@colVals, $data{$col});
1301             }
1302 0           push(@colVals, $data{symbol}, $data{date});
1303 0 0         if (!defined($updSth)) {
1304 0 0         $updSth = $dbh->prepare($updStmt) or die $dbh->errstr;
1305             }
1306 0 0         $updSth->execute(@colVals) or die $updSth->errstr;
1307 0           $updSth->finish();
1308             }
1309             else {
1310 0           my @colVals = ();
1311 0           foreach my $col (@colNames) {
1312 0 0         $data{$col} = 'NULL' if !defined($data{$col});
1313 0           push(@colVals, $data{$col});
1314             }
1315 0 0         if (!defined($insSth)) {
1316 0 0         $insSth = $dbh->prepare($insStmt) or die $dbh->errstr;
1317             }
1318 0 0         $insSth->execute(@colVals) or die $insSth->errstr;
1319 0           $insSth->finish();
1320             }
1321             }
1322             }
1323 0 0         $dbh->commit() if $Config{commit};
1324 0 0         print "Done with $symbol\n" if $Config{verbose};
1325             }
1326              
1327              
1328             sub DatabaseHistoricalFXData {
1329 0     0 0   my ($dbh, $symbol, @res) = @_;
1330 0           my $checked = 0; # flag to ensure not nonsensical or errors
1331 0           my %data; # hash to store data of various completenesses
1332              
1333 0           my $cut = UnixDate(ParseDate("30-Dec-2003"), "%Y%m%d");
1334              
1335 0           my $fx = GetIsoCurrency($symbol);
1336 0           foreach $ARG (@res) { # loop over all supplied symbols
1337 0 0         next if m/^<\!-- .*-->/; # skip lines with html comments (April 2004)
1338             # make sure the first line of data is correct so we don't insert garbage
1339 0 0 0       if ($checked==0 and m/Date(,Open,High,Low)?,Close(,Volume)?/) {
    0          
1340 0           $checked = tr/,//;
1341 0 0         print "Checked now $checked\n" if $Config{verbose};
1342             } elsif ($checked) {
1343 0           my ($date, $open, $high, $low, $close, $volume, $cmd);
1344             # based on the number of elements, ie columns, we split the parsing
1345 0 0 0       if ($checked eq 5 or $checked eq 6) {
1346 0           ($date, $open, $high, $low, $close, $volume) = split(/\,/, $ARG);
1347 0           $date = UnixDate(ParseDate($date), "%Y%m%d");
1348 0           %data = (symbol => $fx,
1349             date => $date,
1350             day_open => $open,
1351             day_high => $high,
1352             day_low => $low,
1353             day_close => $close,
1354             volume => undef); # never any volume info for FX
1355             } else { # no volume for indices
1356 0           print "Unknown currency format: $ARG\n";
1357             }
1358              
1359 0 0         if (Date_Cmp($date,$cut) >= 0) { # if date if on or after cutoff date
1360 0           $data{day_open} /= 100.0; # then scale by a hundred to match the
1361 0           $data{day_low} /= 100.0; # old level "in dollars" rather than the
1362 0           $data{day_high} /= 100.0; # new one "in cents"
1363 0           $data{day_close} /= 100.0;
1364             }
1365              
1366             # now given the data, decide whether we add new data or update old data
1367 0 0         if (ExistsFXDailyData($dbh,$fx,%data)) { # update data if it exists
1368 0           $cmd = "update fxprices set ";
1369             ##$cmd .= "volume = $data{volume}," if defined($data{volume});
1370 0 0         $cmd .= "day_open = $data{day_open}," if defined($data{day_open});
1371 0 0         $cmd .= "day_low = $data{day_low}," if defined($data{day_low});
1372 0 0         $cmd .= "day_high = $data{day_high}," if defined($data{day_high});
1373 0           $cmd .= "day_close = $data{day_close} " .
1374             "where currency = '$data{symbol}' " .
1375             "and date = '$data{date}'";
1376             } else { # insert
1377 0           $cmd = "insert into fxprices (currency, date,";
1378 0 0         $cmd .= "day_open," if defined($data{day_open});
1379 0 0         $cmd .= "day_high," if defined($data{day_high});
1380 0 0         $cmd .= "day_low," if defined($data{day_low});
1381 0           $cmd .= "day_close";
1382             ##$cmd .= ",volume" if defined($data{volume});
1383 0           $cmd .= ") values ('$data{symbol}', '$data{date}', ";
1384 0 0         $cmd .= "$data{day_open}," if defined($data{day_open});
1385 0 0         $cmd .= "$data{day_high}," if defined($data{day_high});
1386 0 0         $cmd .= "$data{day_low}," if defined($data{day_low});
1387 0           $cmd .= "$data{day_close}";
1388             ##$cmd .= ",$data{volume} " if defined($data{volume});
1389 0           $cmd .= ");";
1390             }
1391 0 0         if ($Config{commit}) {
1392 0 0         print "$cmd\n" if $Config{debug};
1393 0 0         $dbh->do($cmd) or die $dbh->errstr;
1394 0           $dbh->commit();
1395             }
1396             } else {
1397             ; # do nothing with bad data
1398             }
1399             }
1400 0 0         print "Done with $fx (using $symbol)\n" if $Config{verbose};
1401             }
1402              
1403             sub DatabaseHistoricalUBCFX {
1404 0     0 0   my ($dbh, $aref, @arg) = @_;
1405              
1406 0           my ($cmd, %data);
1407              
1408 0           foreach my $lref (@$aref) { # loop over all retrieved data
1409 0 0         next if $lref->[0] eq "YYYY/MM/DD";
1410 0           $data{date} = UnixDate(ParseDate($lref->[0]), "%Y%m%d");
1411 0           my $i = 1;
1412 0           foreach my $fx (@arg) {
1413 0 0         if (ExistsFXDailyData($dbh,$fx,%data)) { # update data if it exists
1414 0           $cmd = "update fxprices set ";
1415 0           $cmd .= "day_close = " . 1.0/$lref->[$i] . " " .
1416             "where currency = '$fx' and date = '$data{date}'";
1417             } else {
1418 0           $cmd = "insert into fxprices (currency, date, day_close) ";
1419 0           $cmd .= "values ('$fx', '$data{date}', 1.0/$lref->[$i] )";
1420             }
1421 0           $i++;
1422 0 0         if ($Config{commit}) {
1423 0 0         print "$cmd\n" if $Config{debug};
1424 0 0         $dbh->do($cmd) or die $dbh->errstr;
1425             }
1426             }
1427             #print "Done with $fx (using $symbol)\n" if $Config{verbose};
1428             }
1429 0 0         if ($Config{commit}) {
1430 0           $dbh->commit();
1431             }
1432             }
1433              
1434             sub DatabaseHistoricalOandAFX {
1435 0     0 0   my ($dbh, $aref, @arg) = @_;
1436              
1437 0           my ($cmd, %data);
1438 0           foreach my $line (@$aref) { # loop over all retrieved data
1439             ## split the csv stream with quotewords() from Text::ParseWords
1440 0           my @q = quotewords(',', 0, $line);
1441 0           $data{date} = UnixDate(ParseDate($q[0]), "%Y%m%d");
1442 0           my $i = 1;
1443 0           foreach my $fx (@arg) {
1444 0 0         if (ExistsFXDailyData($dbh,$fx,%data)) { # update data if it exists
1445 0           $cmd = "update fxprices set ";
1446 0           $cmd .= "day_close = " . $q[1] . " " .
1447             "where currency = '$fx' and date = '$data{date}'";
1448             } else {
1449 0           $cmd = "insert into fxprices (currency, date, day_close) ";
1450 0           $cmd .= "values ('$fx', '$data{date}', $q[1] )";
1451             }
1452 0           $i++;
1453 0 0         if ($Config{commit}) {
1454 0 0         print "$cmd\n" if $Config{debug};
1455 0 0         $dbh->do($cmd) or die $dbh->errstr;
1456             }
1457             }
1458             #print "Done with $fx (using $symbol)\n" if $Config{verbose};
1459             }
1460 0 0         if ($Config{commit}) {
1461 0           $dbh->commit();
1462             }
1463             }
1464              
1465             sub DatabaseInfoData { # initialise a row in the info table
1466 0     0 0   my ($dbh, %hash) = @_;
1467 0           foreach my $key (keys %hash) { # now split these into reference to the arrays
1468              
1469             # check stockinfo for $key
1470 0 0         if ( ExistsInfoSymbol($dbh, %{$hash{$key}}) ) {
  0            
1471 0 0         warn "DatabaseInfoData(): Symbol $key already in stockinfo table\n"
1472             if ( $Config{verbose} );
1473 0           next;
1474             }
1475              
1476 0           my $cmd = "insert into stockinfo (symbol, name, exchange, " .
1477             " capitalisation, low_52weeks, high_52weeks, earnings, " .
1478             " dividend, p_e_ratio, avg_volume, active) " .
1479             "values('$hash{$key}{symbol}'," .
1480             $dbh->quote($hash{$key}{name}) . ", " .
1481             " '$hash{$key}{exchange}', " .
1482             " $hash{$key}{market_capitalisation}," .
1483             " $hash{$key}{'52_week_low'}," .
1484             " $hash{$key}{'52_week_high'}," .
1485             " $hash{$key}{earnings_per_share}," .
1486             " $hash{$key}{dividend_per_share}," .
1487             " $hash{$key}{price_earnings_ratio}," .
1488             " $hash{$key}{average_volume}," .
1489             " '1')";
1490 0           $cmd =~ s|'?N/A'?|null|g; # convert (textual) "N/A" into (database) null
1491 0 0         print "$cmd\n" if $Config{debug};
1492 0 0         print "$hash{$key}{symbol} " if $Config{verbose};
1493 0 0         if ($Config{commit}) {
1494 0 0         $dbh->do($cmd) or die $dbh->errstr;
1495 0           $dbh->commit();
1496             }
1497             }
1498             }
1499              
1500              
1501             sub ExistsInfoSymbol {
1502 0     0 0   my ($dbh, %hash) = @_;
1503 0 0         if (!defined($_symExistsInfoSymbolSth)) {
1504 0 0         $_symExistsInfoSymbolSth = $dbh->prepare(qq{select symbol from stockinfo
1505             where symbol = ?})
1506             or die $dbh->errstr;
1507             }
1508 0 0         $_symExistsInfoSymbolSth->execute($hash{symbol})
1509             or die $_symExistsInfoSymbolSth->errstr;
1510 0           my @rows = $_symExistsInfoSymbolSth->fetchrow_array();
1511 0           $_symExistsInfoSymbolSth->finish();
1512              
1513             # plausibility tests here
1514             # someone might care to extend this to consider the 'active' tuple
1515             # maybe if it's false that fact should be noted since
1516             # the user has apparently seen fit to add it to the database (again)
1517 0           return (@rows > 0);
1518             }
1519              
1520              
1521             sub ExistsDailyData($%) {
1522 0     0 0   my ($dbh, %hash) = @_;
1523 0 0         if (!defined($_symExistsDailyDataSth)) {
1524 0 0         $_symExistsDailyDataSth = $dbh->prepare(qq{select symbol from stockprices
1525             where symbol = ? and date = ?})
1526             or die $dbh->errstr;
1527             }
1528 0 0         $_symExistsDailyDataSth->execute($hash{symbol}, $hash{date})
1529             or die $_symExistsDailyDataSth->errstr;
1530 0           my @rows = $_symExistsDailyDataSth->fetchrow_array();
1531 0           $_symExistsDailyDataSth->finish();
1532 0           return (@rows > 0);
1533             }
1534              
1535              
1536             sub ExistsFXDailyData {
1537 0     0 0   my ($dbh,$fx,%hash) = @_;
1538 0           my $stmt = qq{select previous_close, day_open, day_low, day_high,
1539             day_close, day_change
1540             from fxprices
1541             where currency = ?
1542             and date = ?
1543             };
1544              
1545 0 0         print "ExistsFXDailyData():\n\$stmt = $stmt\n" if $Config{debug};
1546              
1547 0           my $sth = $dbh->prepare($stmt);
1548 0           $sth->execute($fx,$hash{date});
1549 0           my @row = $sth->fetchrow_array();
1550 0           $sth->finish();
1551 0           return (@row > 0);
1552             }
1553              
1554              
1555             sub GetDate { # date can be "4:01PM" (same day) or "Jan 15"
1556 0     0 0   my ($value) = @_; # Date::Manip knows how to deal with them...
1557 0           return UnixDate(ParseDate($value), "%Y%m%d");
1558             }
1559              
1560              
1561             sub ParseDailyData { # stuff the output into the hash
1562 0     0 0   my @rra = @_; # we receive an array with references to arrays
1563 0           my %hash; # we return a hash of hashes
1564              
1565 0           foreach my $ra (@rra) { # now split these into reference to the arrays
1566 0           my $key = $ra->[0];
1567 0           $hash{$key}{symbol} = uc $ra->[0];
1568 0           $hash{$key}{name} = RemoveTrailingSpace($ra->[1]);
1569 0           $hash{$key}{day_close} = ParseNumeric($ra->[2]);
1570 0 0         unless ($hash{$key}{date} = GetDate($ra->[3])) {
1571 0           $hash{$key}{date} = "N/A";
1572 0           warn "Ignoring symbol $key with unparseable date\n";
1573             }
1574 0           $hash{$key}{time} = $ra->[4];
1575 0           $hash{$key}{day_change} = ParseNumeric($ra->[5]);
1576 0           $hash{$key}{percent_change} = $ra->[6];
1577 0           $hash{$key}{volume} = $ra->[7];
1578 0           $hash{$key}{average_volume} = $ra->[8];
1579 0           $hash{$key}{bid} = ParseNumeric($ra->[9]);
1580 0           $hash{$key}{ask} = ParseNumeric($ra->[10]);
1581 0           $hash{$key}{previous_close} = ParseNumeric($ra->[11]);
1582 0           $hash{$key}{day_open} = ParseNumeric($ra->[12]);
1583 0           my (@tmp) = split / - /, $ra->[13];
1584 0           $hash{$key}{day_low} = ParseNumeric($tmp[0]);
1585 0           $hash{$key}{day_high} = ParseNumeric($tmp[1]);
1586 0           (@tmp) = split / - /, $ra->[14];
1587 0           $hash{$key}{'52_week_low'} = ParseNumeric($tmp[0]);
1588 0           $hash{$key}{'52_week_high'} = ParseNumeric($tmp[1]);
1589 0           $hash{$key}{earnings_per_share} = $ra->[15];
1590 0           $hash{$key}{price_earnings_ratio} = $ra->[16];
1591 0           $hash{$key}{dividend_date} = $ra->[17];
1592 0           $hash{$key}{dividend_per_share} = $ra->[18];
1593 0           $hash{$key}{yield} = $ra->[19];
1594 0 0         if ($ra->[20] =~ m/(\S*)B$/) {
    0          
    0          
    0          
1595             # convert to millions from billions
1596 0           $hash{$key}{market_capitalisation} = $1*(1e3);
1597             } elsif ($ra->[20] =~ m/(\S*)T$/) {
1598             # reported in trillions -- convert to millions
1599 0           $hash{$key}{market_capitalisation} = $1*(1e6);
1600             } elsif ($ra->[20] =~ m/(\S*)M$/) {
1601             # keep it in millions
1602 0           $hash{$key}{market_capitalisation} = $1;
1603             } elsif ($ra->[20] =~ m/(\S*)K$/) {
1604             # reported in thousands -- convert to millions
1605 0           $hash{$key}{market_capitalisation} = $1*(1e-3);
1606             } else {
1607             # it's not likely a number at all -- pass it on
1608 0           $hash{$key}{market_capitalisation} = $ra->[20];
1609             }
1610 0           $hash{$key}{exchange} = RemoveTrailingSpace($ra->[21]);
1611             }
1612 0           return %hash
1613             }
1614              
1615              
1616             sub ParseNumeric { # parse numeric fields which could be fractions
1617 0     0 0   my $v = shift; # expect one argument
1618 0           $v =~ s/\s*$//; # kill trailing whitespace
1619 0           $v =~ s/\+//; # kill leading plus sign
1620 0 0         if ($v =~ m|(.*) (.*)/(.*)|) {# if it is a fraction
1621 0           return $1 + $2/$3; # return the decimal value
1622             } else { # else
1623 0           return $v; # return the value itself
1624             }
1625             }
1626              
1627              
1628             sub PrintHistoricalData { # simple display routine for hist. data
1629 0     0 0   my (@res) = @_;
1630 0           my $i=1;
1631 0           foreach $ARG (@res) {
1632 0 0         next if m/^<\!-- .*-->/; # skip lines with html comments (April 2004)
1633 0           print $i++, ": $ARG\n";
1634             }
1635             }
1636              
1637              
1638             sub RemoveTrailingSpace {
1639 0     0 0   my $txt = shift;
1640 0           $txt =~ s/\s*$//;
1641 0           return $txt;
1642             }
1643              
1644              
1645             sub ReportDailyData { # detailed display / debugging routine
1646 0     0 0   my (%hash) = @_;
1647 0           foreach my $key (keys %hash) { # now split these into reference to the arrays
1648 0           printf "Name %25s\n", $hash{$key}{name};
1649 0           printf "Symbol %25s\n", $hash{$key}{symbol};
1650 0           printf "Exchange %25s\n", $hash{$key}{exchange};
1651 0           printf "Date %25s\n", $hash{$key}{date};
1652 0           printf "Time %25s\n", $hash{$key}{time};
1653 0           printf "Previous Close %25s\n", $hash{$key}{previous_close};
1654 0           printf "Open %25s\n", $hash{$key}{day_open};
1655 0           printf "Day low %25s\n", $hash{$key}{day_low};
1656 0           printf "Day high %25s\n", $hash{$key}{day_high};
1657 0           printf "Close %25s\n", $hash{$key}{day_close};
1658 0           printf "Change %25s\n", $hash{$key}{day_change};
1659 0           printf "Percent Change %25s\n", $hash{$key}{percent_change};
1660 0           printf "Bid %25s\n", $hash{$key}{bid};
1661 0           printf "Ask %25s\n", $hash{$key}{ask};
1662 0           printf "52-week low %25s\n", $hash{$key}{'52_week_low'};
1663 0           printf "52-week high %25s\n", $hash{$key}{'52_week_high'};
1664 0           printf "Volume %25s\n", $hash{$key}{volume};
1665 0           printf "Average Volume %25s\n", $hash{$key}{average_volume};
1666 0           printf "Dividend date %25s\n", $hash{$key}{dividend_date};
1667 0           printf "Dividend / share %25s\n", $hash{$key}{dividend_per_share};
1668 0           printf "Dividend yield %25s\n", $hash{$key}{yield};
1669 0           printf "Earnings_per_share %25s\n", $hash{$key}{earnings_per_share};
1670 0           printf "P/E ratio %25s\n", $hash{$key}{price_earnings_ratio};
1671 0           printf "Market Capital %25s\n", $hash{$key}{market_capitalisation};
1672             }
1673             }
1674              
1675              
1676             sub ScrubDailyData { # stuff the output into the hash
1677 0     0 0   my %hash = @_; # we receive
1678              
1679             ## Check the date supplied from Yahoo!
1680             ##
1681             ## The first approach was to count all dates for a given market
1682             ## This works well when you have, say, 3 Amex and 5 NYSE stock, and
1683             ## Yahoo just gets one date wrong -- we can then compare the one "off-date"
1684             ## against, say, four "good" dates and override
1685             ## Unfortunately, this doesn't work so well for currencies where you
1686             ## typically only get one, or maybe two, and have nothing to compare against
1687             ##
1688             ## my %date; # date comparison hash
1689             ## foreach my $key (keys %hash) {# store all dates for market
1690             ## $date{$hash{$key}{exchange}}{$hash{$key}{date}}++; # and count'em
1691             ## }
1692             ## -- and later
1693             ## if ($date{$hash{$key}{exchange}}{$hash{$key}{date}} # and outnumbered
1694             ## < $date{$hash{$key}{exchange}}{$Config{today}}) {
1695             ## warn("Override: $hash{$key}{name}: $hash{$key}{date} has only " .
1696             ## "$date{$hash{$key}{exchange}}{$hash{$key}{date}} votes,\n\tbut " .
1697             ## "$hash{$key}{exchange} has " .
1698             ## "$date{$hash{$key}{exchange}}{$Config{today}} " .
1699             ## "votes for $Config{today}");
1700             ## $hash{$key}{date} = $Config{today};
1701             ## } else {
1702             ## warn("$hash{$key}{name} has date $hash{$key}{date}, " .
1703             ## "not $Config{today} but no voting certainty");
1704             ## }
1705             ##
1706             ## $date{$hash{$key}{exchange}}{$Config{today}} = 0
1707             ## unless defined($date{$hash{$key}{exchange}}{$Config{today}});
1708             ##
1709             ## So now we simply override if (and only if) the --forceupdate
1710             ## argument is used. This is still suboptimal if eg you are running this
1711             ## on public holidays. We will have to find a way to filter this
1712             ##
1713 0           foreach my $key (keys %hash) {# now check the date
1714 0 0         if ($hash{$key}{date} eq "N/A") { # if Yahoo! gave us no data
1715 0 0         if ($hash{$key}{symbol} =~ /^\^X/) { # and it was currency
1716 0           my $retry = GetIsoCurrency($hash{$key}{symbol}) . "USD=X";
1717 0           my @retrysymbols;
1718 0           push @retrysymbols, $retry;
1719 0           my (@newarr) = GetDailyData(@retrysymbols);
1720 0 0         print "Retrying $retry:\n", Dumper(@newarr) if $Config{debug};
1721              
1722 0           foreach my $ra (@newarr) { # split these into ref. to the arrays
1723             #print "$ra->[0]\n";
1724             #$hash{$key}{symbol} = uc $ra->[0];
1725 0           $hash{$key}{name} = RemoveTrailingSpace($ra->[1]);
1726 0           $hash{$key}{day_close} = ParseNumeric($ra->[2]);
1727 0           $hash{$key}{day_open} = $hash{$key}{day_low} =
1728             $hash{$key}{day_high} =
1729             $hash{$key}{previous_close} = $hash{$key}{day_change} = -1.2345;
1730 0           $hash{$key}{date} = GetDate($ra->[3]);
1731 0           $hash{$key}{time} = $ra->[4];
1732             }
1733             } else {
1734 0 0         warn "Not scrubbing $hash{$key}{symbol}\n" if $Config{debug};
1735 0           next;
1736             }
1737             }
1738              
1739 0 0         if ($hash{$key}{date} ne $Config{today}) { # if date is not today
1740              
1741 0           my $age = Delta_Format(DateCalc($hash{$key}{date}, $Config{lastbizday},
1742             undef, 2), "approx", 0, "%dt");
1743 0 0         if ($age > 5) {
1744 0           warn "Ignoring $hash{$key}{symbol} ($hash{$key}{name}) " .
1745             "with old date $hash{$key}{date}\n";
1746             #warn "Ignoring $hash{$key}{name} with old date $hash{$key}{date}\n";
1747             #if $Config{debug};
1748 0           $hash{$key}{date} = "N/A";
1749 0           next;
1750             }
1751              
1752 0 0         if (defined($Config{updatedate})) { # and if we have an override
1753 0           $hash{$key}{date} = $Config{updatedate}; # use it
1754 0           warn "Overriding date for $hash{$key}{symbol} ($hash{$key}{name}) " .
1755             "to $Config{updatedate}\n";
1756             #warn "Overriding date for $hash{$key}{name} to $Config{updatedate}\n";
1757             } else {
1758 0           warn "$hash{$key}{symbol} ($hash{$key}{name}) " .
1759             "has date $hash{$key}{date}\n";
1760             #warn "$hash{$key}{name} has date $hash{$key}{date}\n";
1761             }
1762             }
1763              
1764 0 0 0       if ($hash{$key}{previous_close} ne "N/A" and
      0        
1765             ($hash{$key}{day_close} == $hash{$key}{previous_close})
1766             and ($hash{$key}{day_change} != 0)) {
1767 0           $hash{$key}{previous_close} = $hash{$key}{day_close}
1768             - $hash{$key}{day_change};
1769 0           warn "Adjusting previous close for $key from close and change\n";
1770             }
1771              
1772             # Yahoo! decided, on 2004-02-26, to change the ^X indices from
1773             # US Dollar to US Cent, apparently.
1774 0 0         if ($hash{$key}{symbol} =~ /^\^X/) {
1775 0 0 0       if (Date_Cmp(ParseDate($hash{$key}{date}), ParseDate("20040226")) > 0
1776             and not
1777             Date_Cmp(ParseDate($hash{$key}{date}), ParseDate("20050117")) > 0) {
1778 0 0         warn "Scaling $key data from dollars to pennies\n" if $Config{debug};
1779 0           $hash{$key}{previous_close} /= 100;
1780 0           $hash{$key}{day_open} /= 100;
1781 0           $hash{$key}{day_low} /= 100;
1782 0           $hash{$key}{day_high} /= 100;
1783 0           $hash{$key}{day_close} /= 100;
1784 0           $hash{$key}{day_change} /= 100;
1785             }
1786             }
1787             }
1788 0           return %hash;
1789             }
1790              
1791              
1792             sub Sign {
1793 0     0 0   my $x = shift;
1794 0 0         if ($x > 0) {
    0          
1795 0           return 1;
1796             } elsif ($x < 0){
1797 0           return -1;
1798             } else {
1799 0           return 0;
1800             }
1801             }
1802              
1803             sub UpdateDatabase { # update content in the db at end of day
1804 0     0 0   my ($dbh, $res) = @_;
1805 0           my ($stmt, $sth, $rv, $ra, @symbols);
1806              
1807 0           $stmt = qq{ select distinct symbol
1808             from stockinfo
1809             where symbol != ''
1810             and active };
1811 0 0         $stmt .= qq{ and symbol in (select distinct symbol
1812             from portfolio where $res)
1813             } if defined($res);
1814 0           $stmt .= " order by symbol;";
1815              
1816 0 0         print "UpdateDatabase():\n\$stmt = $stmt\n" if $Config{debug};
1817              
1818 0           @symbols = @{ $dbh->selectcol_arrayref($stmt) };
  0            
1819 0 0         print join " ", @symbols, "\n" if $Config{verbose};
1820              
1821 0           my @arr = GetDailyData(@symbols);# retrieve _all_ the data
1822 0           my %data = ParseDailyData(@arr); # put it into a hash
1823 0           %data = ScrubDailyData(%data); # and "clean" it
1824 0 0         ReportDailyData(%data) if $Config{verbose};
1825 0           UpdateInfoData($dbh, %data);
1826 0           DatabaseDailyData($dbh, %data);
1827 0           UpdateTimestamp($dbh);
1828             }
1829              
1830              
1831             sub UpdateFXDatabase {
1832 0     0 0   my ($dbh, $res) = @_;
1833              
1834             # get all non-USD symbols (no USD as we don't need a USD/USD rate)
1835 0           my $stmt = qq{ select distinct currency
1836             from portfolio
1837             where symbol != ''
1838             and currency != 'USD'
1839             };
1840 0 0         $stmt .= " and $res " if (defined($res));
1841              
1842 0 0         print "UpdateFXDatabase():\n\$stmt = $stmt\n" if $Config{debug};
1843              
1844 0           my @symbols = map { GetYahooCurrency($ARG) } @{ $dbh->selectcol_arrayref($stmt)};
  0            
  0            
1845 0 0         print "UpdateFXDatabase(): Symbols are ", join(" ", @symbols), "\n"
1846             if $Config{debug};
1847 0 0         if ($Config{extrafx}) {
1848 0           foreach my $arg (split /,/, $Config{extrafx}) {
1849 0           push @symbols, GetYahooCurrency($arg);
1850             }
1851             }
1852 0 0         if (scalar(@symbols) > 0) { # if there are FX symbols
1853 0           my @arr = GetDailyData(@symbols); # retrieve _all_ the data
1854 0           my %data = ParseDailyData(@arr);
1855 0           %data = ScrubDailyData(%data); # and "clean" it
1856 0 0         ReportDailyData(%data) if $Config{verbose};
1857 0           DatabaseFXDailyData($dbh, %data);
1858             }
1859 0           UpdateTimestamp($dbh);
1860             }
1861              
1862             ## use alternate FX data supply from the PACIFIC / Sauder School / UBC
1863             sub UpdateFXviaUBC {
1864 0     0 0   my ($dbh, $res) = @_;
1865              
1866             # get all non-USD symbols (no USD as we don't need a USD/USD rate)
1867 0           my $stmt = qq{ select distinct currency
1868             from portfolio
1869             where symbol != ''
1870             and currency != 'USD'
1871             };
1872 0 0         $stmt .= " and $res " if (defined($res));
1873 0 0         print "UpdateFXviaUBC():\n\$stmt = $stmt\n" if $Config{debug};
1874              
1875 0           my @symbols = @{ $dbh->selectcol_arrayref($stmt) };
  0            
1876 0 0         print "UpdateFXviaUBC() -- symbols=" .
1877             join(" ", @symbols) . "\n" if $Config{debug};
1878              
1879 0           my %data;
1880 0           $data{date} = $Config{lastbizday};
1881 0 0         $data{date} = $Config{updatedate} if exists($Config{updatedate});
1882              
1883             ## also fetch data via the PACIFIC server at Sauder / UBC
1884 0           my $ubcfx = GetUBCFXHash(\@symbols, $data{date}, $data{date});
1885 0 0         print "UBC server results\n", Dumper($ubcfx) if $Config{debug};
1886              
1887 0           foreach my $key (keys %{$ubcfx}) { # split these into reference to the arrays
  0            
1888 0           my $fx = $key; #$yahoo2iso->{$hash{$key}{symbol}};
1889 0 0         print "Looking at $fx\n" if $Config{debug};
1890 0 0         if (ExistsFXDailyData($dbh, $fx, %data)) {
1891 0           my $stmt = qq{update fxprices
1892             set day_close = ?
1893             where currency = ?
1894             and date = ?
1895             };
1896              
1897 0 0         print "DatabaseFXDailyData():\n\$stmt = $stmt\n" if $Config{debug};
1898 0 0         print "DatabaseFXDailyData(): 1/$ubcfx->{$fx}, $fx, $data{date} \n"
1899             if $Config{debug};
1900              
1901 0 0         if ($Config{commit}) {
1902 0 0         $dbh->do($stmt, undef, 1/$ubcfx->{$fx}, $fx, $data{date})
1903             or warn "Failed for $fx at $data{date}\n";
1904             }
1905              
1906             } else {
1907 0           my $stmt = qq{insert into fxprices (currency, date, day_close) values (?, ?, ?);};
1908              
1909 0 0         print "DatabaseFXDailyData():\n\$stmt = $stmt\n" if $Config{debug};
1910 0 0         print "DatabaseFXDailyData(): 1/$ubcfx->{$fx}, $fx, $data{date} \n"
1911             if $Config{debug};
1912              
1913 0 0         if ($Config{commit}) {
1914 0           my $sth = $dbh->prepare($stmt);
1915 0 0         $sth->execute($fx, $data{date}, 1/$ubcfx->{$fx})
1916             or warn "Failed for $fx at $data{date}\n";
1917 0           $sth->finish();
1918             }
1919             }
1920 0 0         if ($Config{commit}) {
1921 0           $dbh->commit();
1922             }
1923             }
1924             }
1925              
1926             sub UpdateInfoData { # update a row in the info table
1927 0     0 0   my ($dbh, %hash) = @_;
1928 0           foreach my $key (keys %hash) { # now split these into reference to the arrays
1929 0           my $cmd = "update stockinfo " .
1930             "set capitalisation = $hash{$key}{market_capitalisation}, " .
1931             "low_52weeks = $hash{$key}{'52_week_low'}, " .
1932             "high_52weeks = $hash{$key}{'52_week_high'}, " .
1933             "earnings = $hash{$key}{earnings_per_share}, " .
1934             "dividend = $hash{$key}{dividend_per_share}, " .
1935             "p_e_ratio = $hash{$key}{price_earnings_ratio}, " .
1936             "avg_volume = $hash{$key}{average_volume} " .
1937             "where symbol = '$hash{$key}{symbol}';";
1938 0           $cmd =~ s|'?N/A'?|null|g; # convert (textual) "N/A" into (database) null
1939 0 0         print "$cmd\n" if $Config{debug};
1940 0 0         print "$hash{$key}{symbol} " if $Config{verbose};
1941 0 0         if ($Config{commit}) {
1942 0 0         $dbh->do($cmd) or warn "Failed for $hash{$key}{symbol} with $cmd\n";
1943             }
1944             }
1945             }
1946              
1947             sub UpdateTimestamp {
1948 0     0 0   my $dbh = shift;
1949 0           my $cmd = q{update beancounter set data_last_updated='now'};
1950 0 0         print "$cmd\n" if $Config{debug};
1951 0 0         if ($Config{commit}) {
1952 0 0         $dbh->do($cmd) or warn "UpdateTimestamp failed\n";
1953 0           $dbh->commit();
1954             }
1955             }
1956              
1957              
1958             1; # required for a package file
1959              
1960             __END__