450 lines
15 KiB
Perl
450 lines
15 KiB
Perl
#!/usr/bin/env perl
|
|
|
|
use strict;
|
|
use warnings;
|
|
use utf8;
|
|
use feature qw(say);
|
|
|
|
use Getopt::Long qw(GetOptions);
|
|
use HTTP::Cookies;
|
|
use JSON::PP qw(decode_json);
|
|
use LWP::UserAgent;
|
|
use Scalar::Util qw(looks_like_number);
|
|
use Time::HiRes qw(sleep);
|
|
|
|
binmode STDOUT, ':encoding(UTF-8)';
|
|
binmode STDERR, ':encoding(UTF-8)';
|
|
|
|
my %stores = (
|
|
'Australia' => 'https://www.kobo.com/au/en/ebook/',
|
|
'Austria' => 'https://www.kobo.com/at/de/ebook/',
|
|
'Belgium (Dutch)' => 'https://www.kobo.com/be/nl/ebook/',
|
|
'Belgium (French)' => 'https://www.kobo.com/be/fr/ebook/',
|
|
'Brazil' => 'https://www.kobo.com/br/pt/ebook/',
|
|
'Canada (English)' => 'https://www.kobo.com/ca/en/ebook/',
|
|
'Canada (French)' => 'https://www.kobo.com/ca/fr/ebook/',
|
|
'Cyprus' => 'https://www.kobo.com/cy/en/ebook/',
|
|
'Czech Republic' => 'https://www.kobo.com/cz/cs/ebook/',
|
|
'Denmark' => 'https://www.kobo.com/dk/da/ebook/',
|
|
'Eire' => 'https://www.kobo.com/ie/en/ebook/',
|
|
'Estonia' => 'https://www.kobo.com/ee/en/ebook/',
|
|
'Finland' => 'https://www.kobo.com/fi/fi/ebook/',
|
|
'France' => 'https://www.kobo.com/fr/fr/ebook/',
|
|
'Germany' => 'https://www.kobo.com/de/de/ebook/',
|
|
'Greece' => 'https://www.kobo.com/gr/en/ebook/',
|
|
'Hong Kong (Chinese)' => 'https://www.kobo.com/hk/zh/ebook/',
|
|
'Hong Kong (English)' => 'https://www.kobo.com/hk/en/ebook/',
|
|
'India' => 'https://www.kobo.com/in/en/ebook/',
|
|
'Italy' => 'https://www.kobo.com/it/it/ebook/',
|
|
'Japan' => 'https://www.kobo.com/jp/ja/ebook/',
|
|
'Lithuania' => 'https://www.kobo.com/lt/en/ebook/',
|
|
'Luxembourg' => 'https://www.kobo.com/lu/fr/ebook/',
|
|
'Malaysia' => 'https://www.kobo.com/my/en/ebook/',
|
|
'Malta' => 'https://www.kobo.com/mt/en/ebook/',
|
|
'Mexico' => 'https://www.kobo.com/mx/es/ebook/',
|
|
'Netherlands' => 'https://www.kobo.com/nl/nl/ebook/',
|
|
'New Zealand' => 'https://www.kobo.com/nz/en/ebook/',
|
|
'Norway' => 'https://www.kobo.com/no/nb/ebook/',
|
|
'Philippines' => 'https://www.kobo.com/ph/en/ebook/',
|
|
'Poland' => 'https://www.kobo.com/pl/pl/ebook/',
|
|
'Portugal' => 'https://www.kobo.com/pt/pt/ebook/',
|
|
'Romania' => 'https://www.kobo.com/ro/ro/ebook/',
|
|
'Singapore' => 'https://www.kobo.com/sg/en/ebook/',
|
|
'Slovak Republic' => 'https://www.kobo.com/sk/en/ebook/',
|
|
'Slovenia' => 'https://www.kobo.com/si/en/ebook/',
|
|
'South Africa' => 'https://www.kobo.com/za/en/ebook/',
|
|
'Spain' => 'https://www.kobo.com/es/es/ebook/',
|
|
'Sweden' => 'https://www.kobo.com/se/sv/ebook/',
|
|
'Switzerland (French)' => 'https://www.kobo.com/ch/fr/ebook/',
|
|
'Taiwan' => 'https://www.kobo.com/tw/zh/ebook/',
|
|
'Thailand' => 'https://www.kobo.com/th/en/ebook/',
|
|
'Turkey' => 'https://www.kobo.com/tr/tr/ebook/',
|
|
'UK' => 'https://www.kobo.com/gb/en/ebook/',
|
|
'USA' => 'https://www.kobo.com/us/en/ebook/',
|
|
'World-wide' => 'https://www.kobo.com/ww/en/ebook/',
|
|
);
|
|
|
|
my $delay = 1.5;
|
|
my $retries = 3;
|
|
my $timeout = 30;
|
|
my $show_failed = 0;
|
|
my $help = 0;
|
|
|
|
GetOptions(
|
|
'delay=f' => \$delay,
|
|
'retries=i' => \$retries,
|
|
'timeout=i' => \$timeout,
|
|
'show-failed!' => \$show_failed,
|
|
'help|h' => \$help,
|
|
) or usage(2);
|
|
|
|
usage(0) if $help;
|
|
|
|
my $input = shift @ARGV;
|
|
usage(2) unless defined $input && length $input;
|
|
|
|
$delay = 0 if $delay < 0;
|
|
$retries = 0 if $retries < 0;
|
|
$timeout = 5 if $timeout < 5;
|
|
|
|
my $book = clean_book_slug($input);
|
|
die "Could not determine the Kobo book slug from: $input\n" unless length $book;
|
|
die "Invalid Kobo book slug: $book\n" unless $book =~ /\A[[:alnum:]_%+.,'()!-]+\z/;
|
|
|
|
my $jar = HTTP::Cookies->new;
|
|
my $ua = LWP::UserAgent->new(
|
|
timeout => $timeout,
|
|
max_redirect => 8,
|
|
cookie_jar => $jar,
|
|
protocols_allowed => [qw(http https)],
|
|
ssl_opts => { verify_hostname => 1 },
|
|
);
|
|
|
|
# A normal desktop browser identity. The old script used libwww-perl's default
|
|
# identity and launched every request at once, which commonly triggers 403s.
|
|
$ua->agent(
|
|
'Mozilla/5.0 (X11; Linux x86_64) '
|
|
. 'AppleWebKit/537.36 (KHTML, like Gecko) '
|
|
. 'Chrome/124.0 Safari/537.36'
|
|
);
|
|
$ua->default_header('Accept' =>
|
|
'text/html,application/xhtml+xml,application/xml;q=0.9,image/avif,image/webp,*/*;q=0.8');
|
|
$ua->default_header('Accept-Language' => 'en-GB,en;q=0.9');
|
|
$ua->default_header('DNT' => '1');
|
|
$ua->default_header('Upgrade-Insecure-Requests' => '1');
|
|
|
|
my @results;
|
|
my @failures;
|
|
my $index = 0;
|
|
my $total = scalar keys %stores;
|
|
|
|
for my $country (sort keys %stores) {
|
|
++$index;
|
|
my $url = $stores{$country} . $book;
|
|
print STDERR sprintf("[%02d/%02d] %-22s ", $index, $total, $country);
|
|
|
|
my ($response, $attempts) = fetch_with_retries($ua, $url, $retries);
|
|
|
|
if (!$response->is_success) {
|
|
my $status = $response->code . ' ' . $response->message;
|
|
say STDERR "failed ($status)";
|
|
push @failures, [$country, $status, $url];
|
|
polite_pause($delay);
|
|
next;
|
|
}
|
|
|
|
my $html = $response->decoded_content(charset => 'none');
|
|
my ($price, $currency) = extract_price($html);
|
|
|
|
if (!defined $price || !defined $currency) {
|
|
say STDERR 'no price found';
|
|
push @failures, [$country, 'page loaded but price was not found', $url];
|
|
polite_pause($delay);
|
|
next;
|
|
}
|
|
|
|
say STDERR sprintf('ok (%s %.2f)', $currency, $price);
|
|
push @results, {
|
|
country => $country,
|
|
currency => $currency,
|
|
price => $price + 0,
|
|
url => $url,
|
|
};
|
|
|
|
polite_pause($delay);
|
|
}
|
|
|
|
die "\nNo prices were retrieved. Try a larger delay, for example --delay 3.\n"
|
|
unless @results;
|
|
|
|
my %rates_to_eur = fetch_rates_to_eur($ua, [map { $_->{currency} } @results]);
|
|
|
|
for my $row (@results) {
|
|
my $currency = $row->{currency};
|
|
$row->{eur} = $row->{price} * $rates_to_eur{$currency}
|
|
if exists $rates_to_eur{$currency};
|
|
}
|
|
|
|
my $country_width = 0;
|
|
for my $row (@results) {
|
|
my $length = length $row->{country};
|
|
$country_width = $length if $length > $country_width;
|
|
}
|
|
|
|
say '';
|
|
for my $row (sort_results(@results)) {
|
|
if (defined $row->{eur}) {
|
|
printf "%-*s €%7.2f %3s %10.2f\n",
|
|
$country_width, $row->{country}, $row->{eur},
|
|
$row->{currency}, $row->{price};
|
|
} else {
|
|
printf "%-*s %-9s %3s %10.2f\n",
|
|
$country_width, $row->{country}, '(no FX)',
|
|
$row->{currency}, $row->{price};
|
|
}
|
|
}
|
|
|
|
my @converted = grep { defined $_->{eur} } @results;
|
|
if (@converted) {
|
|
my $minimum = (sort { $a->{eur} <=> $b->{eur} } @converted)[0]{eur};
|
|
my @cheapest = grep { abs($_->{eur} - $minimum) < 0.005 } @converted;
|
|
|
|
printf "\nCheapest price: €%.2f\n", $minimum;
|
|
if (@cheapest == 1) {
|
|
printf "Country: %s\n", $cheapest[0]{country};
|
|
printf "Original price: %s %.2f\n",
|
|
$cheapest[0]{currency}, $cheapest[0]{price};
|
|
printf "URL: %s\n", $cheapest[0]{url};
|
|
} else {
|
|
say "Countries tied for cheapest price:";
|
|
for my $row (@cheapest) {
|
|
printf " %s — %s %.2f — %s\n",
|
|
$row->{country}, $row->{currency}, $row->{price}, $row->{url};
|
|
}
|
|
}
|
|
} else {
|
|
say "\nNo exchange rates were available, so no converted cheapest price was calculated.";
|
|
}
|
|
|
|
printf STDERR "\nRetrieved %d of %d stores; %d failed.\n",
|
|
scalar(@results), $total, scalar(@failures);
|
|
|
|
if ($show_failed && @failures) {
|
|
say STDERR "\nFailed stores:";
|
|
for my $failure (@failures) {
|
|
printf STDERR " %-22s %s\n", $failure->[0], $failure->[1];
|
|
}
|
|
}
|
|
|
|
exit 0;
|
|
|
|
sub usage {
|
|
my ($exit_code) = @_;
|
|
print <<'USAGE';
|
|
Usage:
|
|
kobocompare-updated [options] KOBO_URL_OR_SLUG
|
|
|
|
Options:
|
|
--delay SECONDS Pause between countries (default: 1.5)
|
|
--retries NUMBER Retries for 403, 429 and server errors (default: 3)
|
|
--timeout SECONDS Per-request timeout (default: 30)
|
|
--show-failed Print a final list of failed stores
|
|
--help Show this help
|
|
|
|
Examples:
|
|
./kobocompare-updated wings-the-story-of-a-band-on-the-run
|
|
./kobocompare-updated --delay 3 'https://www.kobo.com/es/es/ebook/wings-the-story-of-a-band-on-the-run'
|
|
USAGE
|
|
exit $exit_code;
|
|
}
|
|
|
|
sub clean_book_slug {
|
|
my ($value) = @_;
|
|
$value =~ s/^\s+|\s+$//g;
|
|
$value =~ s/[?#].*\z//; # Drop Kobo search/tracking parameters.
|
|
$value =~ s{/+\z}{};
|
|
$value =~ s{.*/}{};
|
|
return $value;
|
|
}
|
|
|
|
sub polite_pause {
|
|
my ($seconds) = @_;
|
|
return if $seconds <= 0;
|
|
sleep($seconds + rand(0.45));
|
|
}
|
|
|
|
sub fetch_with_retries {
|
|
my ($agent, $url, $max_retries) = @_;
|
|
my $response;
|
|
|
|
for my $attempt (0 .. $max_retries) {
|
|
$response = $agent->get(
|
|
$url,
|
|
'Referer' => 'https://www.kobo.com/',
|
|
'Cache-Control' => 'no-cache',
|
|
'Pragma' => 'no-cache',
|
|
'Sec-Fetch-Dest' => 'document',
|
|
'Sec-Fetch-Mode' => 'navigate',
|
|
'Sec-Fetch-Site' => 'same-origin',
|
|
'Sec-Fetch-User' => '?1',
|
|
);
|
|
|
|
return ($response, $attempt + 1) if $response->is_success;
|
|
|
|
my $code = $response->code || 0;
|
|
last unless $code == 403 || $code == 429 || $code >= 500 || $code == 0;
|
|
last if $attempt == $max_retries;
|
|
|
|
my $retry_after = $response->header('Retry-After');
|
|
my $backoff = (defined $retry_after && $retry_after =~ /^\d+(?:\.\d+)?$/)
|
|
? $retry_after
|
|
: (2 ** $attempt) + 1 + rand(1.0);
|
|
sleep($backoff);
|
|
}
|
|
|
|
return ($response, $max_retries + 1);
|
|
}
|
|
|
|
sub extract_price {
|
|
my ($html) = @_;
|
|
|
|
my $meta_price = extract_meta($html, 'og:price');
|
|
my $meta_currency = extract_meta($html, 'og:currency_code');
|
|
if (defined $meta_price && defined $meta_currency) {
|
|
my $price = normalise_price($meta_price);
|
|
return ($price, uc $meta_currency) if defined $price;
|
|
}
|
|
|
|
while ($html =~ m{<script\b[^>]*type\s*=\s*(["'])application/ld\+json\1[^>]*>(.*?)</script>}gis) {
|
|
my $json_text = $2;
|
|
$json_text =~ s/^\s+|\s+$//g;
|
|
next unless length $json_text;
|
|
|
|
my $data = eval { decode_json($json_text) };
|
|
next if $@ || !defined $data;
|
|
|
|
my ($price, $currency) = find_price_in_json($data);
|
|
return ($price, $currency) if defined $price && defined $currency;
|
|
}
|
|
|
|
# Last-resort fallback for embedded JSON that is not valid JSON-LD.
|
|
if ($html =~ /["']priceCurrency["']\s*:\s*["']([A-Z]{3})["']/i) {
|
|
my $currency = uc $1;
|
|
if ($html =~ /["'](?:salePrice|price)["']\s*:\s*["']?([0-9][0-9.,]*)/i) {
|
|
my $price = normalise_price($1);
|
|
return ($price, $currency) if defined $price;
|
|
}
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub extract_meta {
|
|
my ($html, $wanted) = @_;
|
|
|
|
while ($html =~ m{<meta\b[^>]*>}gi) {
|
|
my $tag = $&;
|
|
my $property = attribute_value($tag, 'property');
|
|
$property = attribute_value($tag, 'name') unless defined $property;
|
|
next unless defined $property && lc($property) eq lc($wanted);
|
|
|
|
my $content = attribute_value($tag, 'content');
|
|
return $content if defined $content;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub attribute_value {
|
|
my ($tag, $name) = @_;
|
|
return $2 if $tag =~ /\b\Q$name\E\s*=\s*(["'])(.*?)\1/is;
|
|
return $1 if $tag =~ /\b\Q$name\E\s*=\s*([^\s>]+)/is;
|
|
return;
|
|
}
|
|
|
|
sub find_price_in_json {
|
|
my ($node) = @_;
|
|
|
|
if (ref $node eq 'ARRAY') {
|
|
for my $item (@$node) {
|
|
my ($price, $currency) = find_price_in_json($item);
|
|
return ($price, $currency) if defined $price && defined $currency;
|
|
}
|
|
return;
|
|
}
|
|
|
|
return unless ref $node eq 'HASH';
|
|
|
|
my $raw_price = exists $node->{price} ? $node->{price}
|
|
: exists $node->{lowPrice} ? $node->{lowPrice}
|
|
: undef;
|
|
my $currency = $node->{priceCurrency};
|
|
|
|
if (defined $raw_price && defined $currency) {
|
|
my $price = normalise_price($raw_price);
|
|
return ($price, uc $currency) if defined $price;
|
|
}
|
|
|
|
for my $key (keys %$node) {
|
|
my ($price, $found_currency) = find_price_in_json($node->{$key});
|
|
return ($price, $found_currency)
|
|
if defined $price && defined $found_currency;
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
sub normalise_price {
|
|
my ($raw) = @_;
|
|
return unless defined $raw;
|
|
|
|
my $value = "$raw";
|
|
$value =~ s/[\s\x{00A0}]//g;
|
|
$value =~ s/[^0-9,.-]//g;
|
|
return unless $value =~ /\d/;
|
|
|
|
if ($value =~ /,/ && $value =~ /\./) {
|
|
my $last_comma = rindex($value, ',');
|
|
my $last_dot = rindex($value, '.');
|
|
if ($last_comma > $last_dot) {
|
|
$value =~ s/\.//g;
|
|
$value =~ tr/,/./;
|
|
} else {
|
|
$value =~ s/,//g;
|
|
}
|
|
} elsif ($value =~ /,/) {
|
|
$value =~ tr/,/./;
|
|
}
|
|
|
|
return unless looks_like_number($value);
|
|
return $value + 0;
|
|
}
|
|
|
|
sub fetch_rates_to_eur {
|
|
my ($agent, $currencies) = @_;
|
|
|
|
my %wanted = map { uc($_) => 1 } grep { defined && /^[A-Za-z]{3}$/ } @$currencies;
|
|
my %to_eur = (EUR => 1);
|
|
delete $wanted{EUR};
|
|
return %to_eur unless keys %wanted;
|
|
|
|
my $quotes = join ',', sort keys %wanted;
|
|
my $url = "https://api.frankfurter.dev/v2/rates?base=EUR"es=$quotes";
|
|
my $response = $agent->get($url, 'Accept' => 'application/json');
|
|
|
|
if (!$response->is_success) {
|
|
warn "Could not retrieve current exchange rates: "
|
|
. $response->status_line . "\n";
|
|
return %to_eur;
|
|
}
|
|
|
|
my $data = eval { decode_json($response->decoded_content) };
|
|
if ($@ || ref $data ne 'ARRAY') {
|
|
warn "Could not parse the exchange-rate response.\n";
|
|
return %to_eur;
|
|
}
|
|
|
|
# API rows are expressed as: 1 EUR = RATE quote-currency units.
|
|
# Therefore 1 quote-currency unit = 1 / RATE EUR.
|
|
for my $row (@$data) {
|
|
next unless ref $row eq 'HASH';
|
|
my $quote = uc($row->{quote} // '');
|
|
my $rate = $row->{rate};
|
|
next unless $quote =~ /^[A-Z]{3}$/;
|
|
next unless defined $rate && looks_like_number($rate) && $rate > 0;
|
|
$to_eur{$quote} = 1 / $rate;
|
|
}
|
|
|
|
return %to_eur;
|
|
}
|
|
|
|
sub sort_results {
|
|
my @rows = @_;
|
|
return sort {
|
|
defined($a->{eur}) && defined($b->{eur}) ? $a->{eur} <=> $b->{eur}
|
|
: defined($a->{eur}) ? -1
|
|
: defined($b->{eur}) ? 1
|
|
: $a->{country} cmp $b->{country}
|
|
} @rows;
|
|
}
|