File Coverage

blib/lib/QRCode/Base45.pm
Criterion Covered Total %
statement 52 52 100.0
branch 12 12 100.0
condition n/a
subroutine 9 9 100.0
pod 2 2 100.0
total 75 75 100.0


line stmt bran cond sub pod time code
1             package QRCode::Base45;
2              
3 2     2   150212 use 5.10.0;
  2         16  
4 2     2   16 use strict;
  2         4  
  2         46  
5 2     2   11 use warnings;
  2         3  
  2         84  
6 2     2   14 use feature 'state';
  2         4  
  2         306  
7 2     2   12 use Carp;
  2         4  
  2         141  
8 2     2   1342 use Encode;
  2         22462  
  2         187  
9 2     2   18 use base qw(Exporter);
  2         4  
  2         1495  
10             our @EXPORT = qw(encode_base45 decode_base45);
11              
12             =head1 NAME
13              
14             QRCode::Base45 - Base45 encoding used in QR codes
15              
16             =head1 VERSION
17              
18             Version 0.01
19              
20             =cut
21              
22             our $VERSION = '0.02';
23              
24             our $ALPHABET = '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ $%*+-./:';
25             # 0 1 2 3 4
26             # 012345678901234567890123456789012345678901234
27              
28             =head1 SYNOPSIS
29              
30             use QRCode::Base45;
31              
32             my $text_for_qrcode = encode_base45($binary_or_utf8_data);
33             my $binary_data = decode_base45($text_from_qrcode);
34              
35             =head1 DESCRIPTION
36              
37             This module handles encoding/decoding of Base45 data,
38             as described in
39             L.
40             Base45 is used especially in QR codes, for example in European vaccination
41             certificates.
42              
43             =head2 encode_base45
44              
45             Takes an arbitrary string as argument, and returns the Base45 representation
46             of it. Character strings (as opposed to byte strings) are encoded to bytes
47             as UTF-8.
48              
49             For zero-length input strings (undef or '') an empty string ('') is returned.
50              
51             =cut
52              
53             sub encode_base45 {
54 56     56 1 29360 my ($input) = @_;
55              
56 56 100       159 return '' if !length $input;
57              
58 54 100       141 $input = Encode::encode('UTF-8', $input)
59             if utf8::is_utf8($input);
60              
61 54         496 my $output = '';
62              
63 54         289 for my $chunk ($input =~ /..?/msg) {
64 86         128 my $sum = 0;
65 86         193 for my $byte (unpack('C*', $chunk)) {
66 121         163 $sum *= 256;
67 121         171 $sum += $byte;
68             }
69 86         173 for (0 .. length($chunk)) {
70 207         329 $output .= substr($ALPHABET, $sum % 45, 1);
71 207         354 $sum = int($sum/45);
72             }
73             }
74              
75 54         255 return $output;
76             }
77              
78             =head2 decode_base45
79              
80             Takes a textual Base45 representation of data, and tries to decode it.
81             Returned value is a byte string (as this function cannot possibly know
82             whether the content should be interpreted as bytes or UTF-8).
83             The caller has to decode the returned byte string to characters afterwards,
84             if needed.
85              
86             For zero-length input strings (undef or '') an empty string ('') is returned.
87              
88             For invalid inputs, such as strings of length 3n+1 or characters
89             outside of the Base45 alphabet, this function croak()s.
90              
91             =cut
92              
93             sub decode_base45 {
94 68     68 1 8581 my ($input) = @_;
95              
96 68 100       179 return '' if !length $input;
97              
98 66 100       760 croak "decode_base45(): invalid input length " . length($input)
99             . " is 3*n+1"
100             if length($input) % 3 == 1;
101              
102 61         102 my $map_count = 0;
103 61         101 state $value_of = { map { $_ => $map_count++ } split //, $ALPHABET };
  45         85  
104              
105 61         104 my $output = '';
106 61         361 for my $chunk ($input =~ /(...?)/g) {
107 96         135 my $sum = 0;
108 96         257 for my $c (reverse map { $value_of->{$_} } split //, $chunk) {
  232         444  
109 224 100       1032 croak "decode_base45(): chunk <$chunk> contains invalid character(s)"
110             if !defined $c;
111 217         271 $sum *= 45;
112 217         299 $sum += $c;
113             }
114              
115 89 100       194 if (length $chunk == 3) {
116 38         80 $output .= pack('C', $sum >> 8);
117 38         55 $sum &= 0x00FF;
118             }
119 89         235 $output .= pack('C', $sum);
120             }
121              
122 54         232 return $output;
123             }
124              
125             =head1 AUTHOR
126              
127             Jan "Yenya" Kasprzak, C<< >>
128              
129             =head1 BUGS
130              
131             Please report any bugs or feature requests to C, or through
132             the web interface at L. I will be notified, and then you'll
133             automatically be notified of progress on your bug as I make changes.
134              
135             The Base45 encoding is relatively new. After it is standardized
136             and maybe used elsewhere apart from QR codes,
137             this module should probably be moved to some other namespace,
138             such as IETF:: or RFCxyzq::.
139              
140             =head1 INSTALLATION
141              
142             To install this module, run the following commands:
143              
144             perl Makefile.PL
145             make
146             make test
147             make install
148              
149             =head1 SUPPORT
150              
151             You can find documentation for this module with the perldoc command.
152              
153             perldoc QRCode::Base45
154              
155              
156             You can also look for information at:
157              
158             =over 4
159              
160             =item * Github repository
161              
162             L
163              
164             =item * RT: CPAN's request tracker (report bugs here)
165              
166             L
167              
168             =item * CPAN Ratings
169              
170             L
171              
172             =item * Search CPAN
173              
174             L
175              
176             =back
177              
178              
179             =head1 ACKNOWLEDGEMENTS
180              
181              
182             =head1 LICENSE AND COPYRIGHT
183              
184             This software is copyright (c) 2021 by Jan "Yenya" Kasprzak.
185              
186             This is free software; you can redistribute it and/or modify it under
187             the same terms as the Perl 5 programming language system itself.
188              
189              
190             =cut
191              
192             1; # End of QRCode::Base45