File Coverage

blib/lib/App/Chart.pm
Criterion Covered Total %
statement 36 38 94.7
branch n/a
condition n/a
subroutine 13 13 100.0
pod n/a
total 49 51 96.0


line stmt bran cond sub pod time code
1             # Copyright 2007, 2008, 2009, 2010, 2011, 2012, 2014, 2015, 2016, 2017 Kevin Ryde
2              
3             # This file is part of Chart.
4             #
5             # Chart is free software; you can redistribute it and/or modify it under the
6             # terms of the GNU General Public License as published by the Free Software
7             # Foundation; either version 3, or (at your option) any later version.
8             #
9             # Chart is distributed in the hope that it will be useful, but WITHOUT ANY
10             # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
11             # FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
12             # details.
13             #
14             # You should have received a copy of the GNU General Public License along
15             # with Chart. If not, see <http://www.gnu.org/licenses/>.
16              
17             package App::Chart;
18 45     45   1399 use 5.010;
  45         200  
19 45     45   220 use strict;
  45         74  
  45         1050  
20 45     45   229 use warnings;
  45         91  
  45         1116  
21 45     45   205 use Carp;
  45         85  
  45         2165  
22 45     45   8970 use Date::Calc;
  45         185463  
  45         1597  
23 45     45   281 use File::Spec;
  45         86  
  45         1145  
24 45     45   203 use List::Util qw(min max);
  45         81  
  45         2743  
25 45     45   11386 use POSIX qw(floor ceil);
  45         185594  
  45         246  
26 45     45   68074 use Regexp::Common 'whitespace';
  45         90530  
  45         174  
27 45     45   32757 use Scalar::Util;
  45         105  
  45         1835  
28 45     45   2111 use Locale::TextDomain;
  45         92640  
  45         298  
29 45     45   58937 use Locale::TextDomain ('App-Chart');
  45         93  
  45         158  
30 45     45   19235 use Glib;
  0            
  0            
31              
32             # uncomment this to run the ### lines
33             #use Smart::Comments;
34              
35             our $VERSION = 262;
36              
37             use Locale::Messages 1.16; # version 1.16 for turn_utf_8_on()
38             BEGIN {
39             Locale::Messages::bind_textdomain_codeset ('App-Chart','UTF-8');
40             Locale::Messages::bind_textdomain_filter ('App-Chart',
41             \&Locale::Messages::turn_utf_8_on);
42             }
43             # sub chart_gettext_filter {
44             # my ($str) = @_;
45             # Locale::Messages::turn_utf_8_on ($str);
46             # $str =~ s/^CONTEXT\(.*?\): *//;
47             # return $str;
48             # }
49              
50             # Return the user's ~/Chart directory, as an absolute path in filesystem
51             # charset encoding.
52             # Note not using Glib::get_home_dir() here, since it wrongly prefers
53             # /etc/passwd file over $HOME.
54             use constant::defer chart_directory => sub {
55             if (defined $ENV{'CHART_DIRECTORY'}) {
56             return $ENV{'CHART_DIRECTORY'}
57             } else {
58             require File::HomeDir;
59             my $home = File::HomeDir->my_home
60             // die "No home directory can be found by File::HomeDir\n";
61             return File::Spec->catdir($home, 'Chart');
62             }
63             };
64              
65             use constant::defer chart_dirbroadcast => sub {
66             require App::Chart::Glib::Ex::DirBroadcast;
67             return App::Chart::Glib::Ex::DirBroadcast->new
68             (File::Spec->catdir(chart_directory(), 'broadcast'));
69             };
70              
71             # force LC_NUMERIC to the locale, whereas perl normally runs with "C"
72             use constant::defer number_formatter => sub {
73             require Number::Format;
74             my $oldlocale = POSIX::setlocale(POSIX::LC_NUMERIC());
75             POSIX::setlocale (POSIX::LC_NUMERIC(), "");
76             my $nf = Number::Format->new;
77             POSIX::setlocale (POSIX::LC_NUMERIC(), $oldlocale);
78             return $nf;
79             };
80              
81             use constant { UP_COLOUR => 'light green',
82             DOWN_COLOUR => 'pink',
83             BAND_COLOUR => 'blue',
84             GREY_COLOUR => 'grey' };
85              
86             #------------------------------------------------------------------------------
87              
88             our %option
89             = (verbose => 0,
90             d_fmt => do {
91             # langinfo D_FMT if available, otherwise fallback to a neutral YYYY-MM-DD
92             eval {
93             require I18N::Langinfo;
94             require I18N::Langinfo::Wide;
95             I18N::Langinfo::Wide::langinfo(I18N::Langinfo::D_FMT())
96             }
97             || '%Y-%m-%d'
98             },
99             http_get_cost => 3000,
100             );
101             $option{'wd_fmt'} = __x('%a {d_fmt}', d_fmt => $option{'d_fmt'});
102              
103              
104              
105             #------------------------------------------------------------------------------
106              
107             sub symbol_sans_suffix {
108             my ($symbol) = @_;
109             return ($symbol =~ /(.*)\./ ? $1 : $symbol);
110             }
111              
112             sub symbol_suffix {
113             my ($symbol) = @_;
114             if ($symbol =~ /([.=][^.=]+)$/) {
115             return $1;
116             } else {
117             return '';
118             }
119             }
120              
121             my $symbol_re = qr{
122             ((\ (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)\ |
123             \^?[^^]([FGHJKMNQUVXZ])) # $4 M code
124             ([0-9]+) # $5 year
125             | ([0-9]+))? # $6 number like LME
126             (\.[^.]+)?$ # $7 suffix
127             }ix;
128              
129             # return commodity part of SYMBOL, or whole symbol (sans suffix) if no
130             # month/year
131             # eg. "GC" for "GCH05.CMX"
132             # "TIN 3" for "TIN 3.LME" -- ?????
133             sub symbol_commodity {
134             my ($symbol) = @_;
135             $symbol =~ $symbol_re or die 'Oops, symbol_re didn\'t match';
136             my $end = ($+[6] # "TIN 3" num right up to suffix
137             // $-[4] # "X08" M-code stop there
138             // $-[0]); # " JAN 06" named stop there, or whole lot
139             return substr ($symbol, 0, $end);
140             }
141             sub symbol_is_front {
142             my ($symbol) = @_;
143             return symbol_commodity($symbol) eq symbol_sans_suffix($symbol);
144             }
145              
146              
147             #------------------------------------------------------------------------------
148              
149             sub symbol_cmp {
150             my ($s1, $s2) = @_;
151             # transform "." so that it comes before a space, so that "ZINC.LME" sorts
152             # before "ZINC 3.LME", etc
153             $s1 =~ tr/^./\000\001/;
154             $s2 =~ tr/^./\000\001/;
155             return (lc($s1) cmp lc($s2)) || ($s1 cmp $s2);
156             }
157              
158              
159             #------------------------------------------------------------------------------
160              
161             my %symbol_setups_done;
162             sub symbol_setups {
163             my ($symbol) = @_;
164             my $suffix = symbol_suffix ($symbol);
165             if ($suffix eq '') {
166             if ($symbol_setups_done{$symbol}) { return; }
167             $symbol_setups_done{$symbol} = 1;
168             ### symbol_setups() NoSuffix\n: $symbol
169             require App::Chart::Suffix::NoSuffix;
170             App::Chart::Suffix::NoSuffix::symbol_setups ($symbol);
171             return;
172             }
173             if ($symbol_setups_done{$suffix}) { return; }
174             $symbol_setups_done{$suffix} = 1;
175              
176             ### symbol_setups() suffix: $suffix
177             if ($symbol =~ /[.=]..?$/) {
178             require App::Chart::Yahoo;
179             }
180              
181             # '.AX' or '=X' becomes 'AX' or 'X'
182             $suffix =~ s/[.=]//;
183              
184             # load App::Chart::Suffix::XX and also any App::Chart::Suffix::XX::Foo, the
185             # latter being meant as pluggable add-ons
186             require Module::Util;
187             require Module::Load;
188             require Module::Find;
189              
190             my $top_module = "App::Chart::Suffix::$suffix";
191             if (Module::Util::find_installed($top_module)) {
192             ### load top: $top_module
193             Module::Load::load ($top_module);
194             }
195             foreach my $sub_module (Module::Find::findsubmod($top_module)) {
196             ### load sub_module: $sub_module
197             Module::Load::load ($sub_module);
198             }
199             }
200              
201             #------------------------------------------------------------------------------
202              
203             # =item C<< App::Chart::symbol_source_help ($symbol) >>
204             #
205             # Return the name of the node (or anchor) in the manual for help on the data
206             # source for C<$symbol>.
207             #
208             # =item App::Chart::setup_source_help ($pred, $node)
209             #
210             # =cut
211              
212             my @source_help_list = ();
213              
214             sub symbol_source_help {
215             my ($symbol) = @_;
216             symbol_setups ($symbol);
217             foreach my $elem (@source_help_list) {
218             if ($elem->[0]->match ($symbol)) {
219             return $elem->[1];
220             }
221             }
222             return undef;
223             }
224             sub setup_source_help {
225             my ($pred, $node) = @_;
226             require App::Chart::Sympred;
227             App::Chart::Sympred::validate ($pred);
228             # newer get higher priority
229             unshift @source_help_list, [ $pred, $node ];
230             }
231              
232              
233             #------------------------------------------------------------------------------
234              
235             sub hms_to_seconds {
236             my ($hour, $minute, $seconds) = @_;
237             return $hour * 60*60 + $minute * 60 + ($seconds || 0);
238             }
239              
240             #------------------------------------------------------------------------------
241              
242             sub seconds_to_hms {
243             my ($seconds) = @_;
244             return (floor ($seconds/3600) % 60,
245             floor ($seconds/60) % 60,
246             $seconds % 60);
247             }
248              
249             #------------------------------------------------------------------------------
250              
251             sub ymd_to_iso {
252             my ($year, $month, $day) = @_;
253             return sprintf ('%04d-%02d-%02d', $year, $month, $day);
254             }
255              
256             sub iso_to_ymd {
257             my ($iso) = @_;
258             return split /-/, $iso;
259             }
260              
261             sub adate_to_ymd {
262             my ($adate) = @_;
263             return Date::Calc::Add_Delta_Days(1970,1,5, $adate);
264             }
265             my $adate_days_base = Date::Calc::Date_to_Days (1970, 1, 5);
266             sub ymd_to_adate {
267             my ($year, $month, $day) = @_;
268             return Date::Calc::Date_to_Days ($year, $month, $day) - $adate_days_base;
269             }
270             sub adate_to_iso {
271             my ($tdate) = @_;
272             return App::Chart::ymd_to_iso (App::Chart::adate_to_ymd ($tdate));
273             }
274              
275             sub tdate_to_ymd {
276             my ($tdate) = @_;
277             return adate_to_ymd (tdate_to_adate ($tdate));
278             }
279             sub tdate_to_iso {
280             my ($tdate) = @_;
281             return adate_to_iso (tdate_to_adate ($tdate));
282             }
283             sub tdate_to_adate {
284             my ($tdate) = @_;
285             return $tdate + floor ($tdate/5)*2;
286             }
287             sub adate_to_tdate_floor {
288             my ($adate) = @_;
289             return floor ($adate / 7) * 5 + min ($adate % 7, 4);
290             }
291             sub adate_to_tdate_ceil {
292             my ($adate) = @_;
293             return floor ($adate / 7) * 5 + min ($adate % 7, 5);
294             }
295             sub ymd_to_tdate_floor {
296             my ($year, $month, $day) = @_;
297             return adate_to_tdate_floor (ymd_to_adate ($year, $month, $day));
298             }
299             sub ymd_to_tdate_ceil {
300             my ($year, $month, $day) = @_;
301             return adate_to_tdate_ceil (ymd_to_adate ($year, $month, $day));
302             }
303              
304              
305             #------------------------------------------------------------------------------
306              
307             sub collapse_whitespace {
308             my ($str) = @_;
309             $str =~ s/\x{A0}+/ /g; # latin1/unicode non-breaking space
310             $str =~ s/$RE{ws}{crop}//g; # leading and trailing whitespace
311             $str =~ s/\s+/ /g; # middle whitespace
312             return $str;
313             }
314              
315             #------------------------------------------------------------------------------
316              
317             sub decimal_sub {
318             my ($x, $y) = @_;
319             # would prefer an actual decimal-arithmetic subtract here
320             my $decimals = max (count_decimals ($x), count_decimals ($y));
321             return sprintf ('%.*f', $decimals, $x - $y);
322             }
323              
324             #------------------------------------------------------------------------------
325              
326             sub count_decimals {
327             my ($str) = @_;
328             my $pos = index ($str, '.');
329             if ($pos >= 0) {
330             return length($str) - $pos - 1;
331             } else {
332             return 0;
333             }
334             }
335              
336             #------------------------------------------------------------------------------
337              
338             # Return min or max of the arguments, ignoring any undefs.
339             # If no args (no undefs that is) then return undef.
340             # List::Util min() and max() return undef for no args, but they want all args
341             # to be numeric.
342             #
343             sub min_maybe {
344             return min (grep {defined} @_);
345             }
346             sub max_maybe {
347             return max (grep {defined} @_);
348             }
349              
350             #------------------------------------------------------------------------------
351              
352             # App::Chart::datafilename ($filename)
353             # App::Chart::datafilename ($dir,...,$dir, $filename)
354             #
355             # Return an absolute path like /usr/share/perl5/App/Chart/$filename,
356             # wherever App/Chart/$filename is found in @INC. $dir arguments specify a
357             # subdirectory like App/Chart/$dir1/$dir2/$filename. All args and the
358             # return are in filesystem charset bytes.
359             #
360             # Module::Find and Module::Util have similar @INC searches, but only for .pm
361             # files it seems.
362             #
363             sub datafilename {
364             foreach my $inc (@INC) {
365             my $filename = File::Spec->catfile ($inc, 'App', 'Chart', @_);
366             if (-e $filename) { return $filename; }
367             }
368             require File::Basename;
369             return File::Spec->catfile (File::Basename::dirname($INC{'App/Chart.pm'}),
370             'Chart', @_);
371             }
372              
373             # return true if range ($alo,$ahi) overlaps range ($blo,$bhi)
374             # each endpoint is taken as inclusive, so say (1,4) and (4,7) do overlap
375             #
376             sub overlap_inclusive_p {
377             my ($alo, $ahi, $blo, $bhi) = @_;
378             return ! ($ahi < $blo || $alo > $bhi);
379             }
380              
381             1;
382             __END__
383              
384             =head1 NAME
385              
386             App::Chart -- various shared Chart things
387              
388             =head1 SYMBOL FUNCTIONS
389              
390             =over 4
391              
392             =cut
393              
394             =item C<< %App::Chart::option >>
395              
396             Various program options.
397              
398             =over 4
399              
400             =item C<verbose> (default false)
401              
402             Print more things (mainly during downloads). This is the C<--verbose>
403             command line option.
404              
405             =item C<d_fmt> (default from C<langinfo()>)
406              
407             C<strftime> format string for a date. Non-ASCII can be included as Perl
408             wide-chars.
409              
410             The default is from C<langinfo(D_FMT)> if the L<I18N::Langinfo> and
411             L<I18N::Langinfo::Wide> modules are available. Otherwise the default is
412             C<%Y-%m-%d> which gives an ISO style YYYY-MM-DD.
413              
414             =item C<wd_fmt> (default C<%a> and C<d_fmt>)
415              
416             C<strftime> format string for a weekday name and date.
417              
418             =item C<http_get_cost> (default 3000)
419              
420             Byte cost reckoned for each separate HTTP request. This is used when
421             choosing between an individual download per symbol or a whole-day download
422             of everything at the exchange.
423              
424             If your connection is badly lagged you could increase this to prefer the
425             single big file. If you want to minimize downloaded bytes then reduce this
426             to roughly HTTP per-request overhead (packet and headers each way), which
427             might be a few hundred bytes.
428              
429             =back
430              
431             =item C<< App::Chart::symbol_sans_suffix ($symbol) >>
432              
433             Return C<$symbol> without its suffix. Eg.
434              
435             App::Chart::symbol_sans_suffix ('BHP.AX') # gives 'BHP'
436             App::Chart::symbol_sans_suffix ('GM') # gives 'GM'
437              
438             =item App::Chart::symbol_suffix ($symbol)
439              
440             Return the suffix part of C<$symbol>, or an empty string if no suffix. Eg.
441              
442             App::Chart::symbol_suffix ('BHP.AX') # gives '.AX'
443             App::Chart::symbol_suffix ('GM') # gives ''
444              
445             =item C<< $cmp = App::Chart::symbol_cmp ($s1, $s2) >>
446              
447             Return -1, 0 or 1 according to C<$s1> less than, equal to, or greater than
448             C<$s2>.
449              
450             Symbols are compared alphabetically, except "^" index symbols come before
451             ordinary symbols.
452              
453             =back
454              
455             =head1 DATE/TIME FUNCTIONS
456              
457             =over 4
458              
459             =item App::Chart::hms_to_seconds ($hour, $minute, [$second])
460              
461             Return a count of seconds since midnight for the given C<$hour>, C<$minute>
462             and C<$seconds>. C<$seconds> is optional and defaults to 0. C<$hour> is in
463             24-hour format, so for instance 16 for 4pm.
464              
465             =item App::Chart::seconds_to_hms ($seconds)
466              
467             Return three values C<($hour, $minute, $seconds)> split from C<$seconds>
468             which is a count of seconds since midnight. C<$hour> is in 24-hour format,
469             so for instance 16 for 4pm.
470              
471             =cut
472              
473             # =item C<< App::Chart::ymd_to_iso ($year, $month, $day) >>
474             #
475             # ...
476              
477             =back
478              
479             =head1 MISC FUNCTIONS
480              
481             =over 4
482              
483             =item App::Chart::collapse_whitespace ($str)
484              
485             Return C<$str> with leading and trailing whitespace stripped, and any runs
486             of whitespace within the string collapsed down to a single space character
487             each.
488              
489             =item App::Chart::decimal_sub ($x, $y)
490              
491             Calculate the difference C<$x - $y> of two decimal number strings C<$x> and
492             C<$y> and return such a string. For example,
493              
494             App::Chart::decimal_sub ('2.55', '1.15') # gives '1.40'
495             App::Chart::decimal_sub ('60.5', '1.05') # gives '59.45'
496              
497             The number of decimal places used and returned is whichever of the two
498             values has the most places.
499              
500             =item C<< App::Chart::count_decimals ($str) >>
501              
502             Return the number of decimal places in the number string C<$str>, ie. how
503             many digits after the decimal point, or 0 if no decimal point. Eg.
504              
505             App::Chart::count_decimals ('123') # is 0
506             App::Chart::count_decimals ('123.') # is 0
507             App::Chart::count_decimals ('123.5') # is 1
508             App::Chart::count_decimals ('2.500') # is 3
509              
510             =item App::Chart::max_maybe ($num, $num, ...)
511              
512             =item App::Chart::min_maybe ($num, $num, ...)
513              
514             Return the maximum or minimum (respectively) among the given numbers.
515             C<undef>s in the arguments are ignored and if there's no arguments, or only
516             C<undef> arguments, the return is C<undef>.
517              
518             =back
519              
520             =head1 SEE ALSO
521              
522             L<chart>
523              
524             =head1 HOME PAGE
525              
526             L<http://user42.tuxfamily.org/chart/index.html>
527              
528             =head1 LICENCE
529              
530             Copyright 2007, 2008, 2009, 2010, 2011, 2012, 2014, 2015, 2016, 2017 Kevin Ryde
531              
532             Chart is free software; you can redistribute it and/or modify it under the
533             terms of the GNU General Public License as published by the Free Software
534             Foundation; either version 3, or (at your option) any later version.
535              
536             Chart is distributed in the hope that it will be useful, but WITHOUT ANY
537             WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
538             FOR A PARTICULAR PURPOSE. See the GNU General Public License for more
539             details.
540              
541             You should have received a copy of the GNU General Public License along with
542             Chart; see the file F<COPYING>. Failing that, see
543             L<http://www.gnu.org/licenses/>.
544              
545             =cut