File Coverage

blib/lib/Finance/Quote/Stooq.pm
Criterion Covered Total %
statement 29 89 32.5
branch 0 22 0.0
condition 0 9 0.0
subroutine 11 12 91.6
pod 0 3 0.0
total 40 135 29.6


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2             # vi: set ts=2 sw=2 noai ic showmode showmatch:
3             #
4             # Copyright (C) 2023, Bruce Schuck <bschuck@asgard-systems.com>
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., 51 Franklin Street, Fifth Floor, Boston, MA
19             # 02110-1301, USA
20             #
21              
22             package Finance::Quote::Stooq;
23              
24 5     5   2676 use strict;
  5         14  
  5         148  
25 5     5   25 use warnings;
  5         11  
  5         147  
26              
27 5     5   25 use Encode qw(decode);
  5         12  
  5         250  
28 5     5   35 use LWP::UserAgent;
  5         9  
  5         31  
29 5     5   125 use HTTP::Request::Common;
  5         10  
  5         343  
30 5     5   40 use HTTP::CookieJar::LWP ();
  5         10  
  5         111  
31 5     5   38 use HTML::TableExtract;
  5         16  
  5         50  
32              
33 5     5   278 use constant DEBUG => $ENV{DEBUG};
  5         8  
  5         364  
34 5     5   34 use if DEBUG, 'Smart::Comments', '###';
  5         25  
  5         31  
35              
36             our $VERSION = '1.58_01'; # TRIAL VERSION
37              
38             my $STOOQ_URL = 'https://stooq.com/q/?s=';
39              
40             sub methods {
41 5     5 0 31 return (stooq => \&stooq,
42             europe => \&stooq,
43             poland => \&stooq);
44             }
45              
46             our @labels = qw/symbol name open high low last bid ask date currency method/;
47              
48             my %currencies_by_link = (
49             '?i=23' => "GBP",
50             '?i=60' => "PLN",
51             '?i=77' => "USD",
52             '?i=89' => "ZAR",
53             );
54              
55             my %currencies_by_symbol = (
56             'p.' => "GBX",
57             '&pound;' => "GBP",
58             'z\x{142}' => "PLN",
59             '\$' => "USD",
60             '?i=89' => "ZAR",
61             );
62              
63             sub labels {
64 5     5 0 18 return (stooq => \@labels,
65             europe => \@labels,
66             poland => \@labels);
67             }
68              
69             sub stooq {
70              
71 0     0 0   my $quoter = shift;
72 0           my @stocks = @_;
73 0           my (%info, $tree, $table, $pricetable, $url, $reply);
74 0           my $cj = HTTP::CookieJar::LWP->new;
75             # my $ua = LWP::UserAgent->new(cookie_jar => $cj);
76 0           my $ua = $quoter->user_agent();
77 0           $ua->cookie_jar($cj);
78 0           $ua->default_header('Accept_Encoding' => 'deflate');
79 0           $ua->default_header('Accept-Language' => 'en-US,en;q=0.5');
80              
81 0           foreach my $stock (@stocks) {
82              
83 0           $url = $STOOQ_URL . $stock;
84 0           $reply = $ua->request( GET $url );
85              
86 0           my $code = $reply->code;
87 0           my $desc = HTTP::Status::status_message($code);
88 0           my $headers = $reply->headers_as_string;
89 0           my $body = $reply->decoded_content;
90              
91             ### Body: $body
92              
93 0           my ($name, $bid, $ask, $last, $open, $high, $low, $date, $currency);
94 0           my ($te, $table);
95              
96 0           $info{ $stock, "symbol" } = $stock;
97              
98 0 0         if ( $code == 200 ) {
99              
100             # Use HTML::TableExtract to parse HTML in $body
101              
102             # The table with the security name is the only table
103             # with bgcolor=e9e9e9 style=z-index:1
104 0           $te = HTML::TableExtract->new(
105             attribs => { bgcolor => 'e9e9e9', style => 'z-index:1' } );
106 0 0 0       if (($te->parse($body)) && ($table = $te->first_table_found)) {
107             ### NameTable Rows: $table->rows()
108 0           ($name) = $table->cell(0,1) =~ m|^.*?(\w.*)$|;
109 0           $te->eof;
110             }
111              
112             # The table with the price data is the only table with
113             # attribute id='t1'
114 0           $te = HTML::TableExtract->new( keep_html => 1,
115             attribs => { id => 't1' } );
116 0 0 0       if (($te->parse($body)) && ($table = $te->first_table_found)) {
117 0           (my $last) = $table->cell(0,0) =~ m|^.+>([\d\.]+)<|;
118 0           (my $currlink) = $table->cell(0,0) =~ m|<a href=t/(\?i=\d+)>|;
119 0 0         if ( $currencies_by_link{$currlink} ) {
120 0           $currency = $currencies_by_link{$currlink};
121             }
122 0           (my $currsymbol) = $table->cell(0,0)
123             =~ m|<a href=t/\?i=\d+>(\S+?)</a>|;
124 0 0         if ( $currencies_by_symbol{$currsymbol} ) {
125 0           $currency = $currencies_by_symbol{$currsymbol};
126             }
127 0           (my $date) = $table->cell(0,1) =~ m|Date.+>(\d{4}-\d{2}-\d{2})<|;
128 0           (my $high, my $low) = $table->cell(1,1)
129             =~ m|.+>([\d\.]+)<.+>([\d\.]+)<|;
130 0           (my $open) = $table->cell(3,0) =~ m|Open.+>([\d\.]+)<|;
131 0           (my $bid) = $table->cell(4,0) =~ m|Bid.+>([\d\.]+)<|;
132 0           (my $ask) = $table->cell(4,1) =~ m|Ask.+>([\d\.]+)<|;
133             # If last and date are defined, save values in hash
134 0 0 0       if ( ($last) && ($date) ) {
135 0           $info{ $stock, 'success' } = 1;
136 0           $info{ $stock, 'method' } = 'stooq';
137 0           $info{ $stock, 'name' } = $name;
138 0           $info{ $stock, 'last' } = $last;
139 0           $info{ $stock, 'currency' } = $currency;
140 0           $info{ $stock, 'open' } = $open;
141 0           $info{ $stock, 'high' } = $high;
142 0           $info{ $stock, 'low' } = $low;
143 0 0         $info{ $stock, 'bid' } = $bid if ($bid);
144 0 0         $info{ $stock, 'ask' } = $ask if ($ask);
145 0           $quoter->store_date(\%info, $stock, { isodate => $date });
146             # Adjust/scale price data if currency is GBX
147 0 0         if ( $currency eq 'GBX' ) {
148 0           foreach my $field ( $quoter->default_currency_fields ) {
149 0 0         next unless ( $info{ $stock, $field } );
150             $info{ $stock, $field } =
151 0           $quoter->scale_field( $info{ $stock, $field }, 0.01 );
152             }
153             }
154             }
155             } else {
156 0           $te->eof;
157 0           $info{ $stock, "success" } = 0;
158 0           $info{ $stock, "errormsg" } =
159             "Error retrieving quote for $stock. Could not parse HTML returned from $url.";
160             }
161              
162             } else { # HTTP Request failed (code != 200)
163 0           $info{ $stock, "success" } = 0;
164 0           $info{ $stock, "errormsg" } =
165             "Error retrieving quote for $stock. Attempt to fetch the URL $url resulted in HTTP response $code ($desc)";
166             }
167              
168             }
169              
170 0 0         return wantarray() ? %info : \%info;
171 0           return \%info;
172              
173             }
174              
175             1;
176              
177             __END__
178              
179             =head1 NAME
180              
181             Finance::Quote::stooq - Obtain quotes from stooq Stock Exchange.
182              
183             =head1 SYNOPSIS
184              
185             use Finance::Quote;
186              
187             $q = Finance::Quote->new;
188              
189             %info = $q->fetch("stooq", "ISLN.UK"); # Only query stooq
190              
191             %info = $q->fetch("poland", "LRQ"); # Failover to other sources OK.
192              
193             =head1 DESCRIPTION
194              
195             This module fetches information from L<https://stooq.com/>.
196              
197             This module is loaded by default on a Finance::Quote object. It's also possible
198             to load it explicitly by placing "stooq" in the argument list to
199             Finance::Quote->new().
200              
201             This module provides "stooq", "poland", and "europe" fetch methods.
202              
203             Information obtained by this module may be covered by Warsaw Stock
204             Exchange terms and conditions.
205              
206             =head1 LABELS RETURNED
207              
208             The following labels are returned:
209              
210             =over
211              
212             =item name
213              
214             =item symbol
215              
216             =item open
217              
218             =item high
219              
220             =item low
221              
222             =item last
223              
224             =item bid
225              
226             =item ask
227              
228             =item date
229              
230             =item currency
231              
232             =back