File Coverage

blib/lib/Finance/Quote/MGEX.pm
Criterion Covered Total %
statement 24 171 14.0
branch 4 52 7.6
condition 3 15 20.0
subroutine 7 17 41.1
pod 0 5 0.0
total 38 260 14.6


line stmt bran cond sub pod time code
1             # Copyright 2008, 2009, 2010, 2011, 2013, 2014, 2015 Kevin Ryde
2              
3             # Finance-Quote-Grab is free software; you can redistribute it and/or
4             # modify it under the terms of the GNU General Public License as published
5             # by the Free Software Foundation; either version 3, or (at your option) any
6             # later version.
7             #
8             # Finance-Quote-Grab is distributed in the hope that it will be useful,
9             # but WITHOUT ANY WARRANTY; without even the implied warranty of
10             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
11             # Public License for more details.
12             #
13             # You should have received a copy of the GNU General Public License
14             # along with this program. If not, see .
15              
16             package Finance::Quote::MGEX;
17 1     1   894 use 5.005;
  1         3  
  1         36  
18 1     1   5 use strict;
  1         1  
  1         31  
19              
20 1     1   3 use vars '$VERSION';
  1         8  
  1         134  
21             $VERSION = 14;
22              
23             # uncomment this to run the ### lines
24             # use Smart::Comments;
25              
26             sub methods {
27 0     0 0 0 return (mgex => \&mgex_quotes);
28             }
29             sub labels {
30 0     0 0 0 return (mgex => [ qw(name currency
31             bid ask
32             open high low last close net
33             method source success errormsg
34              
35             contract_month_iso time
36             ) ]);
37             }
38              
39             # These are about 30 kbytes and 25 kbytes, and update every 60 seconds
40             # apparently, but there's no ETag or Last-Modified to save re-downloading.
41             #
42 1         56 use constant MGEX_AQUOTES_URL =>
43 1     1   5 'http://sites.barchart.com/pl/mgex/aquotes.htx';
  1         1  
44 1         2679 use constant MGEX_WQUOTES_URL =>
45 1     1   3 'http://sites.barchart.com/pl/mgex/wquotes_js.js';
  1         2  
46              
47             my %aq_url = (a => MGEX_AQUOTES_URL,
48             w => MGEX_WQUOTES_URL);
49              
50              
51             # For individual quotes, but the pages are bigger than the wquote/aquote
52             # # eg. http://www.mgex.com/quotes.html?page=quote&sym=MW
53             # use constant MGEX_QUOTES_BASE =>
54             # 'http://www.mgex.com/quotes.html?page=quote&sym=';
55              
56             sub mgex_quotes {
57 0     0 0 0 my ($fq, @symbol_list) = @_;
58             ### mgex_quotes() ...
59             ### @symbol_list
60              
61 0         0 my $ua = $fq->user_agent;
62 0         0 my %quotes;
63              
64             # while (@symbol_list) {
65             # my $symbol = shift @symbol_list;
66             # my $commodity = symbol_to_commodity($symbol);
67             # ### $commodity
68             # unless ($commodity) {
69             # _errormsg (\%quotes, [$symbol], 'No such symbol');
70             # next;
71             # }
72             # my $this_list = [ $symbol ];
73             #
74             # }
75              
76              
77             # split into symbols Ixxxx and AJxxx which are aquote and the rest wquote
78             my @aq_keys;
79 0         0 my %aq_symbol_list;
80 0         0 foreach my $symbol (@symbol_list) {
81 0 0       0 my $key = ($symbol =~ /^[AI]/ ? 'a' : 'w');
82 0 0       0 unless ($aq_symbol_list{$key}) {
83 0         0 push @aq_keys, $key;
84             }
85 0         0 push @{$aq_symbol_list{$key}}, $symbol;
  0         0  
86             }
87             ### @aq_keys
88             ### %aq_symbol_list
89              
90 0         0 foreach my $aq (@aq_keys) {
91 0         0 require HTTP::Request;
92 0         0 my $req = HTTP::Request->new ('GET', $aq_url{$aq});
93 0         0 $ua->prepare_request ($req);
94 0         0 $req->accept_decodable; # we use decoded_content() below
95 0         0 $req->user_agent (__PACKAGE__."/$VERSION " . $req->user_agent);
96             ### req: $req->as_string
97              
98 0         0 my $resp = $ua->request ($req);
99 0         0 resp_to_quotes ($fq, $resp, \%quotes, $aq_symbol_list{$aq});
100             }
101 0 0       0 return wantarray() ? %quotes : \%quotes;
102             }
103              
104             sub symbol_to_commodity {
105 0     0 0 0 my ($str) = @_;
106 0         0 $str =~ s/[A-Z][0-9]+$//;
107 0         0 return $str;
108             }
109              
110             my %aquote_name_to_commodity
111             = ('PIT NCI' => 'IC',
112             'NCI' => 'IC',
113             'HRWI' => 'IH',
114             'HRSI' => 'IP',
115             'SRWI' => 'IW',
116             'NSI' => 'IS',
117             'AJC' => 'AJ',
118             );
119              
120             my %month_code_to_month = ('F' => 1,
121             'G' => 2,
122             'H' => 3,
123             'J' => 4,
124             'K' => 5,
125             'M' => 6,
126             'N' => 7,
127             'Q' => 8,
128             'U' => 9,
129             'V' => 10,
130             'X' => 11,
131             'Z' => 12);
132             my @month_to_month_code
133             = (undef, 'F','G','H','J','K','M','N','Q','U','V','X','Z');
134              
135             my %month_name_to_number = ('jan' => 1,
136             'feb' => 2,
137             'mar' => 3,
138             'apr' => 4,
139             'may' => 5,
140             'jun' => 6,
141             'jul' => 7,
142             'aug' => 8,
143             'sep' => 9,
144             'oct' => 10,
145             'nov' => 11,
146             'dec' => 12);
147              
148              
149             sub _name_to_NSCM {
150 0     0   0 my ($name) = @_;
151             ### _name_to_NSCM(): $name
152 0         0 my ($symbol, $commodity, $month, $y);
153              
154 0 0       0 if ($name =~ /^((PIT )?[A-Z]+) ([A-Za-z]+) '([0-9][0-9])$/) {
    0          
155             ### aquotes.htx name ...
156             # "SRWI Feb '06"
157             # "PIT NCI Jan '06"
158             #
159             # in the past there were call options too, but not now
160             # "NCI Mar '07 1900 Call"
161             #
162 0         0 $name = $1;
163 0         0 $commodity = $1;
164 0         0 my $month_name = $3;
165 0         0 $y = $4;
166              
167 0   0     0 $commodity = $aquote_name_to_commodity{$commodity}
168             || return; # if unrecognised
169 0   0     0 $month = $month_name_to_number{lc($month_name)}
170             || return; # if unrecognised
171 0         0 $symbol = $commodity
172             . $month_to_month_code[$month]
173             . $y; # two digit year
174              
175             } elsif ($name =~ m{\((([A-Z]+)([A-Z])([0-9]+))\)}) {
176             # wquotes_js.js name like
177             # "MGEX (MWN9)"
178             # "KCBT (KEZ9)"
179             #
180 0         0 $name = undef;
181 0         0 $symbol = $1;
182 0         0 $commodity = $2;
183 0         0 my $month_code = $3;
184 0   0     0 $month = $month_code_to_month{$month_code}
185             || return; # if unrecognised
186 0         0 $y = $4;
187              
188             } else {
189 0         0 return;
190             }
191              
192 0         0 my $year = _y_to_year($y);
193             ### $year
194 0         0 my $contract_month = sprintf ('%04d-%02d-01', $year, $month);
195              
196 0         0 return ($name, $symbol, $commodity, $contract_month);
197             }
198              
199             sub _y_to_year {
200 0     0   0 my ($y) = @_;
201 0 0       0 my $modulus = (length($y) == 1 ? 10 : 100);
202 0         0 my $half = $modulus / 2;
203 0         0 my $base = _this_year() - $half;
204 0         0 return $base + (($y - $base) % $modulus);
205             }
206             sub _this_year {
207 0     0   0 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime(time());
208 0         0 return $year + 1900;
209             }
210              
211             # store to hashref $quotes all the $symbol_list symbols picked out of a
212             # HTTP::Response in $resp
213             sub resp_to_quotes {
214 0     0 0 0 my ($fq, $resp, $quotes, $symbol_list) = @_;
215              
216 0         0 my %want_symbol;
217 0         0 @want_symbol{@$symbol_list} = (); # hash slice
218 0         0 my %seen_symbol;
219              
220 0         0 foreach my $symbol (@$symbol_list) {
221 0         0 $quotes->{$symbol,'method'} = 'mgex';
222 0         0 $quotes->{$symbol,'source'} = __PACKAGE__;
223 0         0 $quotes->{$symbol,'success'} = 0; # false if not in returned
224             }
225              
226 0 0       0 if (! $resp->is_success) {
227 0         0 _errormsg ($quotes, $symbol_list, $resp->status_line);
228 0         0 return;
229             }
230 0         0 my $content = $resp->decoded_content (raise_error => 1);
231              
232 0         0 $content = _javascript_document_write ($content);
233             ### $content
234 0         0 $content =~ s/ / /g;
235              
236 0         0 my $page_date;
237 0 0       0 if ($content =~ /for ([a-zA-Z]+ [0-9]{1,2}, [0-9]{4})/) {
238 0         0 $page_date = $1;
239             ### $page_date
240             }
241              
242 0         0 require HTML::TableExtract;
243 0         0 my $te = HTML::TableExtract->new
244             (headers => [ qr/Contract/i,
245             qr/Last/i,
246             qr/Change/i,
247             qr/Bid/,
248             qr/Ask/i,
249             qr/Open/i,
250             qr/High/,
251             qr/Low/i,
252             qr/Settle/i,
253             qr/Time/i ]);
254 0         0 $te->parse ($content);
255 0 0       0 if (! $te->tables) {
256 0         0 _errormsg ($quotes, $symbol_list, 'table not matched');
257 0         0 return;
258             }
259              
260 0         0 foreach my $row ($te->rows) {
261             ### $row
262 0 0       0 if (! defined $row->[0]) {
263             ### undef empty row, skip ...
264 0         0 next;
265             }
266              
267 0         0 my ($orig_name, $last, $change, $bid, $ask, $open, $high, $low,
268             $prev, $last_time)
269 0         0 = map { my $str = $_;
270 0         0 $str =~ s/^\s+//;
271 0         0 $str =~ s/\s+$//;
272 0         0 $str } @$row;
273              
274 0         0 my ($name, $symbol, $commodity, $contract_month)
275             = _name_to_NSCM ($orig_name);
276 0 0       0 if (! defined $symbol) {
277             ### unrecognised row: $orig_name
278 0         0 next;
279             }
280             ### $name
281             ### $symbol
282             ### $commodity
283             ### $contract_month
284 0 0       0 if (! exists $want_symbol{$symbol}) {
285             ### not wanted: $symbol
286 0         0 next;
287             }
288              
289             # "5 x 195-2" or whatever for count of bid/offers
290             # seen in 2006, but maybe no longer generated
291 0         0 my ($bid_count, $ask_count);
292 0 0       0 if ($bid =~ s/([0-9]+) x //) { $bid_count = $1; }
  0         0  
293 0 0       0 if ($ask =~ s/([0-9]+) x //) { $ask_count = $1; }
  0         0  
294              
295             # trailing "s" for settlement price
296 0         0 $last =~ s/s$//i;
297              
298             # "unch" for no change
299 0 0       0 if ($change =~ /unch/i) { $change = 0; }
  0         0  
300              
301 0         0 $bid = _dash_frac_to_decimals ($bid);
302 0         0 $ask = _dash_frac_to_decimals ($ask);
303              
304 0         0 $open = _dash_frac_to_decimals ($open);
305 0         0 $high = _dash_frac_to_decimals ($high);
306 0         0 $low = _dash_frac_to_decimals ($low);
307 0         0 $last = _dash_frac_to_decimals ($last);
308 0         0 $prev = _dash_frac_to_decimals ($prev);
309 0         0 $change = _dash_frac_to_decimals ($change);
310              
311 0         0 my $date = $page_date;
312             ### $last_time
313 0 0       0 if ($last_time =~ m{^\d+/\d+/\d+$}) {
314             ### "Time" field like "09/26/11" in wquote ...
315 0         0 $date = $last_time;
316 0         0 undef $last_time;
317             }
318              
319 0         0 $quotes->{$symbol,'name'} = $name;
320 0         0 $quotes->{$symbol,'currency'} = 'USD';
321 0         0 $quotes->{$symbol,'contract_month_iso'} = $contract_month;
322              
323 0 0       0 if (defined $date) {
324 0         0 $fq->store_date($quotes, $symbol, {usdate => $date});
325             }
326 0         0 $quotes->{$symbol,'time'} = $last_time;
327              
328 0         0 $quotes->{$symbol,'bid'} = $bid;
329 0         0 $quotes->{$symbol,'ask'} = $ask;
330 0 0       0 if (defined $bid_count) {
331 0         0 $quotes->{$symbol,'bid_count'} = $bid_count;
332             }
333 0 0       0 if (defined $ask_count) {
334 0         0 $quotes->{$symbol,'ask_count'} = $ask_count;
335             }
336 0         0 $quotes->{$symbol,'open'} = $open;
337 0         0 $quotes->{$symbol,'high'} = $high;
338 0         0 $quotes->{$symbol,'low'} = $low;
339 0         0 $quotes->{$symbol,'last'} = $last;
340 0         0 $quotes->{$symbol,'net'} = $change;
341 0         0 $quotes->{$symbol,'close'} = $prev;
342 0         0 $quotes->{$symbol,'success'} = 1;
343              
344 0         0 $seen_symbol{$symbol} = 1;
345             }
346              
347             # message in any not seen in page
348 0         0 delete @want_symbol{keys %seen_symbol}; # hash slice
349 0         0 _errormsg ($quotes, [keys %want_symbol], 'No such symbol');
350             }
351              
352             sub _errormsg {
353 0     0   0 my ($quotes, $symbol_list, $errormsg) = @_;
354 0         0 foreach my $symbol (@$symbol_list) {
355 0         0 $quotes->{$symbol,'errormsg'} = $errormsg;
356             }
357             }
358              
359             #------------------------------------------------------------------------------
360             # generic
361              
362             # convert number like "99-1" with dash fraction to decimals like "99.125"
363             # single dash digit is 1/8s
364             # three dash digits -xxy is xx 1/32s and y is 0,2,5,7 for further 1/4, 2/4,
365             # or 3/4 of 1/32
366             #
367             my %qu_to_quarter = (''=>0, 0=>0, 2=>1, 5=>2, 7=>3);
368             sub _dash_frac_to_decimals {
369 0     0   0 my ($str) = @_;
370              
371 0 0       0 $str =~ /^\+?(.+)-(.*)/ or return $str;
372 0         0 my $int = $1;
373 0         0 my $frac = $2;
374              
375 0 0 0     0 if (length ($frac) == 1) {
    0          
376             # 99-1
377             # only 2 decimals for 1/4s, since for various commodities that's the
378             # minimum tick
379 0         0 return $int + ($frac / 8);
380              
381             } elsif (length ($frac) == 2 || length ($frac) == 3) {
382             # 109-30, in 1/32nds
383             # 99-130, in 1/32s then last dig 0,2,5,7 further 1/4s of that
384 0         0 my $th = substr $frac, 0, 2;
385 0 0       0 if ($th > 31) {
386 0         0 die "Barchart: dash thirtyseconds out of range: $str";
387             }
388 0         0 my $qu = substr($frac, 2, 1);
389 0 0       0 if (! exists $qu_to_quarter{$qu}) {
390 0         0 die "Barchart: dash thirtyseconds further quarters unrecognised: $str";
391             }
392 0         0 $qu = $qu_to_quarter{$qu};
393 0         0 return $int + (($th + $qu / 4) / 32);
394              
395             } else {
396 0         0 die "Barchart: unrecognised dash number: $str";
397             }
398             }
399              
400             #------------------------------------------------------------------------------
401             # javascript mangling
402              
403             # $str contains javascript style calls
404             # document.write('foo')
405             # return a string of the output produced by those calls
406             # this only works for constant strings
407             # escaped quotes \' are turned into just ' in the return
408             #
409             sub _javascript_document_write {
410 1     1   854 my ($str) = @_;
411 1         2 my $ret = '';
412 1         15 while ($str =~ /document\.write\('((\\.|[^\'])*)'\)/sg) {
413 1         4 $ret .= _javascript_string_unquote($1);
414             }
415 1         3 return $ret;
416             }
417              
418             # undo javascript string backslash quoting in STR, per
419             #
420             # https://developer.mozilla.org/en/JavaScript/Guide/Values,_Variables,_and_Literals#String_Literals
421             #
422             # Encode::JavaScript::UCS does \u, but not the rest
423             #
424             # cf Java as such not quite the same:
425             # unicode: http://java.sun.com/docs/books/jls/third_edition/html/lexical.html#100850
426             # strings: http://java.sun.com/docs/books/jls/third_edition/html/lexical.html#101089
427             #
428             my %javascript_backslash = ('b' => "\b", # backspace
429             'f' => "\f", # formfeed
430             'n' => "\n", # newline
431             'r' => "\r",
432             't' => "\t", # tab
433             'v' => "\013", # vertical tab
434             );
435             sub _javascript_string_unquote {
436 3     3   83 my ($str) = @_;
437 3         11 $str =~ s{\\(?:
438             ((?:[0-3]?[0-7])?[0-7]) # $1 \377 octal latin-1
439             |x([0-9a-fA-F]{2}) # $2 \xFF hex latin-1
440             |u([0-9a-fA-F]{4}) # $3 \uFFFF hex unicode
441             |(.) # $4 \n etc escapes
442             )
443             }{
444 8 100 66     45 (defined $1 ? chr(oct($1))
    100 33        
445             : defined $4 ? ($javascript_backslash{$4} || $4)
446             : chr(hex($2||$3))) # \x,\u hex
447             }egx;
448 3         7 return $str;
449             }
450              
451             1;
452             __END__