diff --git a/makedebian.pl b/makedebian.pl index aa57b6458..cd388ab56 100755 --- a/makedebian.pl +++ b/makedebian.pl @@ -109,7 +109,7 @@ if ($product eq "webmin") { $size = int(`du -sk $tmp_dir`); @deps = ( "perl", "libnet-ssleay-perl", "openssl", "libauthen-pam-perl", "libpam-runtime", "libio-pty-perl", "unzip", "shared-mime-info", "tar", "libdigest-sha-perl", "libdigest-md5-perl", "gzip" ); $deps = join(", ", @deps); -@recommends = ( "libdatetime-perl", "libdatetime-timezone-perl", "libdatetime-locale-perl", "libtime-piece-perl", "libencode-detect-perl", "libtime-hires-perl", "libsocket6-perl", "html2text", "qrencode", "libdbi-perl", "libdbd-mysql-perl", "libdbd-mariadb-perl", "libjson-xs-perl", "libsys-syslog-perl" ); +@recommends = ( "libdatetime-perl", "libdatetime-timezone-perl", "libdatetime-locale-perl", "libtime-piece-perl", "libencode-detect-perl", "libtime-hires-perl", "libsocket6-perl", "html2text", "libdbi-perl", "libdbd-mysql-perl", "libdbd-mariadb-perl", "libjson-xs-perl", "libsys-syslog-perl" ); $recommends = join(", ", @recommends); open(CONTROL, ">$control_file"); print CONTROL <; +{ our $VERSION = '0.001' } + +use Exporter qw< import >; +our @EXPORT_OK = qw< + rs_correction + rs_correction_string + rs_encode + rs_encode_string +>; +our %EXPORT_TAGS = (all => [ @EXPORT_OK ]); + +our $ALPHA = 2; +our $PRIME_POLY = 0X11D; + +######################################################################## +# +# Public Interface + +sub rs_correction ($msg, $nsym) { + my $g = _rs_generator_poly($nsym); + my ($quot, $rem) = _gf256_poly_div([$msg->@*, (0) x $nsym ], $g); + return $rem; +} + +sub rs_correction_string ($msg, $nsym) { + my $aref = [ map { ord($_) } split m{}mxs, $msg ]; + return join '', map { chr($_) } rs_correction($aref, $nsym)->@*; +} + +sub rs_encode ($msg, $nsym) { + return [ $msg->@*, rs_correction($msg, $nsym)->@* ]; +} + +sub rs_encode_string ($msg, $nsym) { + return $msg . rs_correction_string($msg, $nsym); +} + + +######################################################################## +# +# Private Interface + +sub _rs_generator_poly ($nsym) { + state $gs = [ [1] ]; + push $gs->@*, _gf256_poly_mul($gs->[-1], [1, _gf256_pow($ALPHA, $gs->$#*)]) + while $nsym > $gs->$#*; + return $gs->[$nsym]; +} + +sub _gf256_table_for { + state $table_for = do { + my (@exp, @log); + my $x = 1; + for my $i (0 .. 254) { + $exp[$i] = $exp[$i + 255] = $x; + $log[$x] = $i; + $x <<= 1; + $x ^= $PRIME_POLY if $x & 0x100; + } + { exp => \@exp, log => \@log }; + }; +} + +sub _gf256_mul ($x, $y) { + state $table_for = _gf256_table_for(); + state $exp = $table_for->{exp}; + state $log = $table_for->{log}; + return 0 if $x == 0 || $y == 0; + return $exp->[$log->[$x] + $log->[$y]]; +} + +sub _gf256_pow ($x, $pow) { + state $table_for = _gf256_table_for(); + state $exp = $table_for->{exp}; + state $log = $table_for->{log}; + return $exp->[($log->[$x] * $pow) % 255]; +} + +sub _gf256_poly_mul ($p, $q) { + my $lp = $p->@*; + my $lq = $q->@*; + my $lr = $lp + $lq - 1; + my $r = [ (0) x $lr ]; + for my $i (0 .. ($lp - 1)) { + for my $j (0 .. ($lq - 1)) { + $r->[$i + $j] ^= _gf256_mul($p->[$i], $q->[$j]); + } + } + return $r; +} + +sub _gf256_poly_div ($x, $y) { + my $retval = [ $x->@* ]; + for my $i (0 .. ($x->$#* - $y->$#*)) { + my $c = $retval->[$i]; + if ($c != 0) { + for my $j (1 .. $y->$#*) { + if ($y->[$j] != 0) { + $retval->[$i + $j] ^= _gf256_mul($y->[$j], $c); + } + } + } + } + my $separator = $retval->$#* - $y->$#*; + my $quot = [ $retval->@[0 .. $separator] ]; + my $rem = [ $retval->@[$separator + 1 .. $retval->$#*] ]; + return ($quot, $rem); +} + +1; diff --git a/vendor_perl/QRCode/Encoder.pm b/vendor_perl/QRCode/Encoder.pm new file mode 100644 index 000000000..224990d41 --- /dev/null +++ b/vendor_perl/QRCode/Encoder.pm @@ -0,0 +1,252 @@ +package QRCode::Encoder; +use v5.24; +use warnings; +use experimental qw< signatures >; +{ our $VERSION = '0.005' } + +use Math::ReedSolomon::Encoder qw< rs_correction_string >; +use QRCode::Encoder::QRSpec qw< :all >; +use QRCode::Encoder::Matrix qw< add_matrix >; +use Exporter qw< import >; +our @EXPORT_OK = qw< + qr_best_params + qr_encode + qr_mode +>; +our %EXPORT_TAGS = (all => [ @EXPORT_OK ]); + +sub qr_mode ($octets) { + return 'numeric' if $octets =~ m{\A \d* \z}mxs; + return 'alphanumeric' + if $octets =~ m{\A [0-9A-Z\x20\x24\x25\x2a\x2b\x2d-\x2f\x3a]+ \z}mxs; + return 'kanji' + if $octets =~ m{\A + (?: # start of a pair + (?: [\x81-\x9f\xe0-\xea] [\x40-\x7e\x80-\xfc]) + | (?: \xeb [\x40-\x7e\x80\xbf]) + )+ + \z}mxs; + return 'byte'; +} + +sub qr_best_params (@args) { + state $rank_for = { L => 1, M => 2, Q => 3, H => 4 }; + my %args = scalar(@args) % 2 ? (octets => @args) : @args; + my $size = length($args{octets}); + my $mode = $args{mode} // qr_mode($args{octets}); + + my $version = $args{version}; + my $min_version = $args{'min-version'} // 1; + $version //= 40 if $min_version eq 40; + + my $level = $args{level}; + my $min_level = $args{min_level} // 'L'; + $level //= 'H' if $min_level eq 'H'; + + if (defined($level)) { + my $minv = qrspec_min_version_for($mode, $size, $level) + or die "no suitable version for $mode/$size/$level"; + if (defined($version)) { # just check + die "version $version insufficient for $mode/$size/$level" + if $version < $minv; + } + else { + my $req = $args{min_version} // 1; + $version = $minv < $req ? $req : $minv; + } + } + elsif (defined($version)) { + my $min_rank = $rank_for->{$min_level}; + for my $candidate (qw< H Q M L >) { + last if $rank_for->{$candidate} < $min_rank; + my $minv = qrspec_min_version_for($mode, $size, $candidate); + if ($minv <= $version) { + $level = $candidate; + last; + } + } + die "no level for $mode/$size/$version (min rank: $min_rank)" + unless defined $level; + } + else { # nothing is defined, go for the smaller size + $level = $min_level; + my $min_rank = $rank_for->{$level}; + my $minv = qrspec_min_version_for($mode, $size, $level); + my $req = $args{'min-version'} // 1; + $version = $minv <= $req ? $req : $minv; + for my $candidate (qw< L M Q H >) { + next if $rank_for->{$candidate} <= $min_rank; + my $altv = qrspec_min_version_for($mode, $size, $candidate); + last if $altv > $minv; + $level = $candidate; + } + } + + return ( + %args, + mode => $mode, + level => $level, + version => $version, + ); +} + +sub qr_encode (@args) { + my %args = qr_best_params(@args); + my $mode = $args{mode}; + my $level = $args{level}; + my $size = length($args{octets}); + $args{version} //= qrspec_min_version_for($mode, $size, $level); + _add_encoded(\%args); + _add_codewords(\%args); + _add_error_correction(\%args); + add_matrix(\%args); + _add_plot(\%args); + return \%args; +} + +sub _add_plot ($args) { + $args->{plot} = [ + map { [ map { $_ & 0x01 ? '*' : ' ' } $_->@* ] } $args->{matrix}->@* + ]; + return $args; +} + +sub _add_encoded ($args) { + state $encoder_for = { + numeric => \&_qr_encode_numeric, + alphanumeric => \&_qr_encode_alphanumeric, + byte => \&_qr_encode_byte, + kanji => \&_qr_encode_kanji, + }; + + my $mode = $args->{mode}; + my $encoder = $encoder_for->{$mode} or die "missing mode <$mode>\n"; + my $mi = qrspec_mode_indicator($mode); + + my $version = $args->{version}; + my $size = length($args->{octets}); + + my $lis = qrspec_length_indicator($mode, $args->{version}); + my $li = _dec2bin(length($args->{octets}), $lis); + + $args->{encoded} = $mi . $li . $encoder->($args->{octets}); + + return $args; +} + +sub _add_codewords ($args) { + my $bit_stream = $args->{encoded}; + my $data_size = qrspec_data_size($args->@{qw< version level >}); + my $needed_bits = length($bit_stream); + my $residual_bits = 8 * $data_size - $needed_bits; + die "not enough bits, wrong version?\n" if $residual_bits < 0; + my $terminator_size = $residual_bits >= 4 ? 4 : $residual_bits; + $bit_stream .= '0' x $terminator_size; + $residual_bits -= $terminator_size; + if (my $pad1 = $residual_bits % 8) { + $bit_stream .= '0' x $pad1; + $residual_bits -= $pad1; + } + while ($residual_bits > 0) { + $bit_stream .= '11101100'; + last if $residual_bits == 8; + $bit_stream .= '00010001'; + $residual_bits -= 16; + } + $args->{bit_stream} = $bit_stream; + $args->{codewords} = pack 'B*', $bit_stream; + return $args; +} + +sub _add_error_correction ($args) { + my @blocks = qrspec_ecc_spec($args->@{qw< version level >}); + $args->{ecc} = \@blocks; + my $expanded = ''; + my $codewords = $args->{codewords}; + my $i = 0; + my (@codewords, @eccs); + for my $block (@blocks) { + my ($ecc, $data, $count) = $block->@{qw< ecc data count >}; + while ($count-- > 0) { + my $cw = substr($codewords, $i, $data); + push @codewords, $cw; + push @eccs, rs_correction_string($cw, $ecc); + $i += $data; + } + } + $args->{expanded} = _linearize(\@codewords) . _linearize(\@eccs); + $args->{remainder} = qrspec_remainder($args->{version}); + return $args; +} + +sub _linearize ($strings) { + return $strings->[0] if $strings->@* == 1; + my $retval = ''; + my $i = 0; + my $n = length($strings->[-1]); + while ($i < $n) { + for my $string ($strings->@*) { + next if $i >= length($string); + $retval .= substr($string, $i, 1); + } + ++$i; + } + return $retval; +} + +sub _dec2bin ($v, $n) { substr(unpack('B*', pack('N', $v)), -$n, $n) } + +sub _qr_encode_numeric ($octets) { + state $n_bits_for = [ 4, 7, 10 ]; + my $i = 0; # index of start of substr, advanced each iteration + my $r = length($octets); # number of residual octets to take + my $bits = ''; + while ($r > 0) { + my $l = $r >= 3 ? 3 : $r; + $bits .= _dec2bin(substr($octets, $i, $l), $n_bits_for->[$l - 1]); + $r -= $l; + $i += $l; + } + return $bits; +} + +sub _qr_encode_alphanumeric ($octets) { + state $chars = [ 0 .. 9, 'A' .. 'Z', split //, ' $%*+-./:' ]; + state $value_for = { map { $chars->[$_] => $_ } 0 .. $chars->$#* }; + my $i = 0; # index of start of substr, advanced each iteration + my $r = length($octets); # number of residual octets to take + my $bits = ''; + while ($r > 0) { + if ($r == 1) { + $bits .= _dec2bin($value_for->{substr($octets, $i, 1)}, 6); + $r = 0; + } + else { + my $value = $value_for->{substr($octets, $i++, 1)} * 45; + $value += $value_for->{substr($octets, $i++, 1)}; + $bits .= _dec2bin($value, 11); + $r -= 2; + } + } + return $bits; +} + +sub _qr_encode_kanji ($octets) { + my $i = 0; + my $r = length($octets); + my $bits = ''; + while ($r > 0) { + my $v = unpack('n', substr($octets, $i, 2)); + $v -= ($v <= 0x9FFC) ? 0x8140 : 0xC140; + $v = ($v >> 8) * 0xC0 + ($v & 0xFF); + $bits .= _dec2bin($v, 13); + $r -= 2; + $i += 2; + } + return $bits; +} + +sub _qr_encode_byte ($octets) { unpack 'B*', $octets } + + +1; diff --git a/vendor_perl/QRCode/Encoder/Matrix.pm b/vendor_perl/QRCode/Encoder/Matrix.pm new file mode 100644 index 000000000..e410f1fbe --- /dev/null +++ b/vendor_perl/QRCode/Encoder/Matrix.pm @@ -0,0 +1,394 @@ +package QRCode::Encoder::Matrix; +use v5.24; +use experimental qw< signatures >; +use List::Util qw< sum >; +use QRCode::Encoder::QRSpec qw< + qrspec_version_pattern + qrspec_format_pattern + qrspec_alignment_patterns +>; + +use Exporter qw< import >; +our @EXPORT_OK = qw< add_matrix >; + +# Parts liberally taken from libqrencode/qrspec.c, which is distributed +# with LGPL license + +sub add_matrix ($data) { + add_base_matrix($data); + add_quiet($data); + add_finders($data); + add_format_reservations($data); # MUST: before add_timing + add_version($data); + add_timing($data); + add_alignments($data); + add_codewords($data); + add_mask($data); + return $data; +} + +sub stringify_matrix ($data) { + my @chunks; + my $matrix = $data->{matrix}; + for my $row ($matrix->@*) { + push @chunks, join '', map { chr($_) } $row->@*; + } + return join "\n", @chunks; +} + +sub stringify_matrix_2 ($data) { + my @chunks; + my $matrix = $data->{matrix}; + for my $row ($matrix->@*) { + push @chunks, join '', map { ($_ & 0x1) ? '#' : ' ' } $row->@*; + } + return join "\n", @chunks; +} + +sub add_base_matrix ($data) { + my $side = $data->{side_size} = 17 + 4 * $data->{version}; + my $eside = $data->{eside_size} = $side + 8; + $data->{matrix} = [ map { [ ( 0x38 ) x $eside ] } 1 .. $eside ]; + return $data; +} + +sub add_finders ($data) { + my $eside_size = $data->{eside_size}; + add_finder($data, 4 - 1, 4 - 1); + add_finder($data, 4 - 1, $eside_size - 8 - 4); + add_finder($data, $eside_size - 8 - 4, 4 - 1); + return $data; +} + +sub add_quiet ($data) { + my $es = $data->{eside_size}; + my $matrix = $data->{matrix}; + for my $i (0 .. 3) { + for my $j (0 .. $es - 1) { + $matrix->[$i][$j] = + $matrix->[$es - 1 - $i][$j] = + $matrix->[$j][$i] = + $matrix->[$j][$es - 1 - $i] = 0x30; + } + } + return $data; +} + +sub add_finder ($data, $x, $y) { + state $shape = [ + [ 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30 ], + [ 0x30, 0x31, 0x31, 0x31, 0x31, 0x31, 0x31, 0x31, 0x30 ], + [ 0x30, 0x31, 0x30, 0x30, 0x30, 0x30, 0x30, 0x31, 0x30 ], + [ 0x30, 0x31, 0x30, 0x31, 0x31, 0x31, 0x30, 0x31, 0x30 ], + [ 0x30, 0x31, 0x30, 0x31, 0x31, 0x31, 0x30, 0x31, 0x30 ], + [ 0x30, 0x31, 0x30, 0x31, 0x31, 0x31, 0x30, 0x31, 0x30 ], + [ 0x30, 0x31, 0x30, 0x30, 0x30, 0x30, 0x30, 0x31, 0x30 ], + [ 0x30, 0x31, 0x31, 0x31, 0x31, 0x31, 0x31, 0x31, 0x30 ], + [ 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30, 0x30 ], + ]; + my $matrix = $data->{matrix}; + for my $yoff (0 .. 8) { + my $Y = $y + $yoff; + for my $xoff (0 .. 8) { + my $X = $x + $xoff; + $matrix->[$Y][$X] = $shape->[$yoff][$xoff]; + } + } + return $data; +} + +sub add_format_reservations ($data) { + my $matrix = $data->{matrix}; + my $es = $data->{eside_size}; + for my $i (0 .. 7) { + $matrix->[12][$i + 4] = + $matrix->[12][$i + $es - 4 - 8] = + $matrix->[$i + $es - 4 - 8][12] = + $matrix->[$i + 4][12] = 0x32; + } + $matrix->[12][12] = 0x32; + $matrix->[$es - 4 - 8][12] = 0x31; + return $data; +} + +sub add_version_reservations ($data) { + return $data->{version} <= 6; + + my $matrix = $data->{matrix}; + my $ecstart = $data->{eside_size} - 4 - 7 - 4; + for my $i (4 .. 9) { + for my $j ($ecstart .. ($ecstart + 2)) { + $matrix->[$i][$j] = $matrix->[$j][$i] = 0x32; + } + } + + return $data; +} + +sub add_timing ($data) { + my $matrix = $data->{matrix}; + my $es = $data->{eside_size}; + for my $i (12 .. ($es - 4 - 8 - 1)) { + $matrix->[$i][10] = $matrix->[10][$i] = 0x35 ^ ($i & 1); + } + return $data; +} + +sub try_add_alignment_pattern ($data, $x, $y) { + state $shape = [ + [ 0x31, 0x31, 0x31, 0x31, 0x31 ], + [ 0x31, 0x30, 0x30, 0x30, 0x31 ], + [ 0x31, 0x30, 0x31, 0x30, 0x31 ], + [ 0x31, 0x30, 0x30, 0x30, 0x31 ], + [ 0x31, 0x31, 0x31, 0x31, 0x31 ], + ]; + $x += 4; # offset by quiet zone + $y += 4; # offset by quiet zone + my $matrix = $data->{matrix}; + return if $matrix->[$y][$x] < 0x34 + || $matrix->[$y][$x + 4] < 0x34 + || $matrix->[$y + 4][$x] < 0x34; + for my $i (0 .. 4) { + for my $j (0 .. 4) { + $matrix->[$y + $i][$x + $j] = $shape->[$i][$j]; + } + } +} + +sub add_alignments ($data) { + my @offset = qrspec_alignment_patterns($data->{version}); + for my $y_center (@offset) { + for my $x_center (@offset) { + try_add_alignment_pattern($data, $x_center - 2, $y_center - 2); + } + } + return $data; +} + +sub bits_iterator ($data) { + my $n_expanded = length($data->{expanded}); + my $rem = $data->{remainder}; + my $i = 0; + my @queue; + return sub { + if (! @queue) { + if ($i < $n_expanded) { + push @queue, split m{}mxs, unpack 'B*', substr($data->{expanded}, $i++, 1); + } + else { + push @queue, ('0') x $rem; + $rem = 0; + } + } + return shift(@queue); + }; +} + +sub add_codewords ($data) { + my $it = bits_iterator($data); + my $matrix = $data->{matrix}; + my $side_size = $data->{side_size}; + + # start from a fake position that would be the last bit of a + # hypothetical "-1" codeword + my $x = $side_size - 2; + my $y = $side_size; + my $left = 1; + my $d = -1; # direction + while (defined(my $bit = $it->())) { + while ('necessary') { + if ($x % 2 == $left) { + ++$x; + $y += $d; + } + else { + --$x; + } + if ($d < 0 && $y < 0) { # reset condition + $x -= 2; + $y = 0; + $d = 1; + } + elsif ($d > 0 && $y >= $side_size) { # other reset condition + $x -= 2; + $y = $side_size - 1; + $d = -1; + } + if ($x == 6) { # left timing column, skip a column entirely + $x = 5; + $left = 0; + } + last if $matrix->[$y + 4][$x + 4] > 0x37; # found suitable position + } + $matrix->[$y + 4][$x + 4] = $bit ? 0x37 : 0x36; + } + return $data; +} + +sub evaluate_matrix ($matrix) { + return 0 + + evaluate_matrix_adjacents_and_11311($matrix) + + evaluate_matrix_blocks($matrix) + + evaluate_matrix_proportion($matrix); +} + +sub __row ($matrix, $i) { + my $max_idx = $matrix->[0]->$#* - 4; + join('', map { $matrix->[$i + 4][$_] & 0x01 ? 1 : 0 } 4 .. $max_idx); +} + +sub __col ($matrix, $i) { + my $max_idx = $matrix->[0]->$#* - 4; + join('', map { $matrix->[$_][$i + 4] & 0x01 ? 1 : 0 } 4 .. $max_idx); +} + +sub evaluate_matrix_adjacents_and_11311 ($matrix) { + my $side_size = $matrix->[0]->@* - 8; + my $penalty = 0; + my $penalty2 = 0; + for my $i (0 .. ($side_size - 1)) { + for my $seq (__row($matrix, $i), __col($matrix, $i)) { + + # adjacences + my @contributions = + map { $_ - 2 } + grep { $_ >= 5 } + map { length } + split m{(0+)}mxs, $seq; + $penalty += sum(@contributions) if @contributions; + + # 000011311 | 113110000 + my @matches = $seq =~ m{ + ( + (?: (?<=0000) 1011101 ) # look behind... + | (?: 1011101 (?=0000) ) # or look ahead + ) + }gmxs; + $penalty2 += 40 * scalar(@matches); + + } + } + return $penalty + $penalty2; +} + +sub evaluate_matrix_blocks ($matrix) { + my $side_size = $matrix->[0]->@* - 8; + my $penalty = 0; + for my $i (0 .. ($side_size - 2)) { + for my $j (0 .. ($side_size - 2)) { + my $count = 0; + for my $offset ([0, 0], [0, 1], [1, 0], [1, 1]) { + my ($oi, $oj) = $offset->@*; + $count++ if $matrix->[$i + $oi + 4][$j + $oj + 4] & 1; + } + $penalty += 3 if ($count == 0) || ($count == 4); + } + } + return $penalty; +} + +sub evaluate_matrix_proportion ($matrix) { + my $count = sum( map { map { $_ & 0x1 ? 1 : 0 } $_->@* } $matrix->@* ); + my $side_size = $matrix->[0]->@* - 8; + my $total = $side_size * $side_size; + my $percentage = 100 * $count / $total; + my $deviation = abs($percentage - 50); + my $penalty = 10 * int($deviation / 5); + return $penalty; +} + +sub masked_matrix ($data, $mask_id) { + state $mask_for = { + 0 => sub ($i, $j) { (($i + $j) % 2) == 0 }, + 1 => sub ($i, $j) { ($i % 2) == 0 }, + 2 => sub ($i, $j) { ($j % 3) == 0 }, + 3 => sub ($i, $j) { (($i + $j) % 3) == 0 }, + 4 => sub ($i, $j) { ((int($i / 2) + int($j / 3)) % 2) == 0 }, + 5 => sub ($i, $j) { ((($i * $j) % 2) + (($i * $j) % 3)) == 0 }, + 6 => sub ($i, $j) { (((($i * $j) % 2) + (($i * $j) % 3)) % 2) == 0 }, + 7 => sub ($i, $j) { (((($i + $j) % 2) + (($i * $j) % 3)) % 2) == 0 }, + }; + my $matrix = $data->{matrix}; + my @masked; + my $eside_size = $data->{eside_size}; + my $mask = $mask_for->{$mask_id}; + for my $i (0 .. ($eside_size - 1)) { + for my $j (0 .. ($eside_size - 1)) { + if (($matrix->[$i][$j] >= 0x36) && $mask->($i - 4, $j - 4)) { + $masked[$i][$j] = $matrix->[$i][$j] ^ 0x01; + } + else { + $masked[$i][$j] = $matrix->[$i][$j]; + } + } + } + return \@masked; +} + +sub add_mask ($data) { + my ($best_mask_id, $best_matrix, $best_penalty); + $data->{masked} = \my @masked; + for my $mask_id (0 .. 7) { + my $matrix = masked_matrix($data, $mask_id); + add_format($matrix, $data->{level}, $mask_id); + push @masked, $matrix; + my $penalty = evaluate_matrix($matrix); + ($best_mask_id, $best_matrix, $best_penalty) = ($mask_id, $matrix, $penalty) + if (! $best_matrix) || $penalty < $best_penalty; + } + $data->{original_matrix} = delete($data->{matrix}); + $data->{matrix} = $best_matrix; + $data->{mask_id} = $best_mask_id; + return $data; +} + +sub add_format ($matrix, $level, $mask_id) { + my $fmt = qrspec_format_pattern($level, $mask_id); + my $es = $matrix->[0]->@*; + + # 1st copy + my $format = $fmt; + for my $i (0 .. 7) { + $matrix->[12][$es - 1 - 4 - $i] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + } + for my $i (8 .. 14) { + $matrix->[$es - 1 - 4 - 14 + $i][12] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + } + + # 2nd copy + $format = $fmt; + for my $i (0 .. 5) { + $matrix->[4 + $i][12] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + } + for my $i (6, 7) { + $matrix->[4 + 1 + $i][12] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + } + # 8 + $matrix->[4 + 1 + 7][11] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + for my $i (9 .. 14) { + $matrix->[4 + 1 + 7][9 + 9 - $i] = $format & 0x01 ? 0x31 : 0x30; + $format >>= 1; + } + + return $matrix; +} + +sub add_version ($data) { + my $vp = qrspec_version_pattern($data->{version}) // return; + my $matrix = $data->{matrix}; + my $ecstart = $data->{eside_size} - 4 - 7 - 4; + for my $i (4 .. 9) { + for my $j ($ecstart .. ($ecstart + 2)) { + $matrix->[$i][$j] = $matrix->[$j][$i] = 0x30 ^ ($vp & 1); + $vp >>= 1; + } + } + return $data; +} + +1; diff --git a/vendor_perl/QRCode/Encoder/QRSpec.pm b/vendor_perl/QRCode/Encoder/QRSpec.pm new file mode 100644 index 000000000..df13636d2 --- /dev/null +++ b/vendor_perl/QRCode/Encoder/QRSpec.pm @@ -0,0 +1,292 @@ +package QRCode::Encoder::QRSpec; +use v5.24; +use warnings; +use experimental qw< signatures >; + +use Exporter qw< import >; +our @EXPORT_OK = qw< + qrspec_ecc_spec + qrspec_data_size + qrspec_ecc_size + qrspec_width + qrspec_remainder + qrspec_min_version + qrspec_min_version_for + qrspec_length_indicator + qrspec_maximum_words + qrspec_mode_indicator + qrspec_alignment_patterns + qrspec_format_pattern + qrspec_version_pattern +>; +our %EXPORT_TAGS = (all => [@EXPORT_OK]); + +# Liberally taken from libqrencode/qrspec.c, which is distributed with +# LGPL license + +sub qrspec_ecc_spec ($version, $level) { + state $ecc_table = [ + map { _zip_hash([qw< L M Q H >], $_) } ( + # L M Q H + [[ 1, 0], [ 1, 0], [ 1, 0], [ 1, 0]], + [[ 1, 0], [ 1, 0], [ 1, 0], [ 1, 0]], + [[ 1, 0], [ 1, 0], [ 2, 0], [ 2, 0]], + [[ 1, 0], [ 2, 0], [ 2, 0], [ 4, 0]], + [[ 1, 0], [ 2, 0], [ 2, 2], [ 2, 2]], + [[ 2, 0], [ 4, 0], [ 4, 0], [ 4, 0]], + [[ 2, 0], [ 4, 0], [ 2, 4], [ 4, 1]], + [[ 2, 0], [ 2, 2], [ 4, 2], [ 4, 2]], + [[ 2, 0], [ 3, 2], [ 4, 4], [ 4, 4]], + [[ 2, 2], [ 4, 1], [ 6, 2], [ 6, 2]], + [[ 4, 0], [ 1, 4], [ 4, 4], [ 3, 8]], + [[ 2, 2], [ 6, 2], [ 4, 6], [ 7, 4]], + [[ 4, 0], [ 8, 1], [ 8, 4], [12, 4]], + [[ 3, 1], [ 4, 5], [11, 5], [11, 5]], + [[ 5, 1], [ 5, 5], [ 5, 7], [11, 7]], + [[ 5, 1], [ 7, 3], [15, 2], [ 3, 13]], + [[ 1, 5], [10, 1], [ 1, 15], [ 2, 17]], + [[ 5, 1], [ 9, 4], [17, 1], [ 2, 19]], + [[ 3, 4], [ 3, 11], [17, 4], [ 9, 16]], + [[ 3, 5], [ 3, 13], [15, 5], [15, 10]], + [[ 4, 4], [17, 0], [17, 6], [19, 6]], + [[ 2, 7], [17, 0], [ 7, 16], [34, 0]], + [[ 4, 5], [ 4, 14], [11, 14], [16, 14]], + [[ 6, 4], [ 6, 14], [11, 16], [30, 2]], + [[ 8, 4], [ 8, 13], [ 7, 22], [22, 13]], + [[10, 2], [19, 4], [28, 6], [33, 4]], + [[ 8, 4], [22, 3], [ 8, 26], [12, 28]], + [[ 3, 10], [ 3, 23], [ 4, 31], [11, 31]], + [[ 7, 7], [21, 7], [ 1, 37], [19, 26]], + [[ 5, 10], [19, 10], [15, 25], [23, 25]], + [[13, 3], [ 2, 29], [42, 1], [23, 28]], + [[17, 0], [10, 23], [10, 35], [19, 35]], + [[17, 1], [14, 21], [29, 19], [11, 46]], + [[13, 6], [14, 23], [44, 7], [59, 1]], + [[12, 7], [12, 26], [39, 14], [22, 41]], + [[ 6, 14], [ 6, 34], [46, 10], [ 2, 64]], + [[17, 4], [29, 14], [49, 10], [24, 46]], + [[ 4, 18], [13, 32], [48, 14], [42, 32]], + [[20, 4], [40, 7], [43, 22], [10, 67]], + [[19, 6], [18, 31], [34, 34], [20, 61]], + ) + ]; + + my ($b1, $b2) = $ecc_table->[$version - 1]{$level}->@*; + my $data_size = qrspec_data_size($version, $level); + my $ecc_size = qrspec_ecc_size($version, $level); + my @retval; + + push @retval, { + count => $b1, + data => int($data_size / ($b1 + $b2)), + ecc => int($ecc_size / ($b1 + $b2)), + }; + + push @retval, { + count => $b2, + data => ($retval[0]{data} + 1), + ecc => $retval[0]{ecc}, + } if $b2; + + return @retval; +} + +sub qrspec_width ($version) { 17 + $version * 4 } + +{ + state $table = [ + map { $_->{ec} = _zip_hash([qw< L M Q H >], $_->{ec}); $_ } ( + { words => 26, remainder => 0, ec => [ 7, 10, 13, 17]}, + { words => 44, remainder => 7, ec => [ 10, 16, 22, 28]}, + { words => 70, remainder => 7, ec => [ 15, 26, 36, 44]}, + { words => 100, remainder => 7, ec => [ 20, 36, 52, 64]}, + { words => 134, remainder => 7, ec => [ 26, 48, 72, 88]}, + { words => 172, remainder => 7, ec => [ 36, 64, 96, 112]}, + { words => 196, remainder => 0, ec => [ 40, 72, 108, 130]}, + { words => 242, remainder => 0, ec => [ 48, 88, 132, 156]}, + { words => 292, remainder => 0, ec => [ 60, 110, 160, 192]}, + { words => 346, remainder => 0, ec => [ 72, 130, 192, 224]}, + { words => 404, remainder => 0, ec => [ 80, 150, 224, 264]}, + { words => 466, remainder => 0, ec => [ 96, 176, 260, 308]}, + { words => 532, remainder => 0, ec => [ 104, 198, 288, 352]}, + { words => 581, remainder => 3, ec => [ 120, 216, 320, 384]}, + { words => 655, remainder => 3, ec => [ 132, 240, 360, 432]}, + { words => 733, remainder => 3, ec => [ 144, 280, 408, 480]}, + { words => 815, remainder => 3, ec => [ 168, 308, 448, 532]}, + { words => 901, remainder => 3, ec => [ 180, 338, 504, 588]}, + { words => 991, remainder => 3, ec => [ 196, 364, 546, 650]}, + { words =>1085, remainder => 3, ec => [ 224, 416, 600, 700]}, + { words =>1156, remainder => 4, ec => [ 224, 442, 644, 750]}, + { words =>1258, remainder => 4, ec => [ 252, 476, 690, 816]}, + { words =>1364, remainder => 4, ec => [ 270, 504, 750, 900]}, + { words =>1474, remainder => 4, ec => [ 300, 560, 810, 960]}, + { words =>1588, remainder => 4, ec => [ 312, 588, 870, 1050]}, + { words =>1706, remainder => 4, ec => [ 336, 644, 952, 1110]}, + { words =>1828, remainder => 4, ec => [ 360, 700, 1020, 1200]}, + { words =>1921, remainder => 3, ec => [ 390, 728, 1050, 1260]}, + { words =>2051, remainder => 3, ec => [ 420, 784, 1140, 1350]}, + { words =>2185, remainder => 3, ec => [ 450, 812, 1200, 1440]}, + { words =>2323, remainder => 3, ec => [ 480, 868, 1290, 1530]}, + { words =>2465, remainder => 3, ec => [ 510, 924, 1350, 1620]}, + { words =>2611, remainder => 3, ec => [ 540, 980, 1440, 1710]}, + { words =>2761, remainder => 3, ec => [ 570, 1036, 1530, 1800]}, + { words =>2876, remainder => 0, ec => [ 570, 1064, 1590, 1890]}, + { words =>3034, remainder => 0, ec => [ 600, 1120, 1680, 1980]}, + { words =>3196, remainder => 0, ec => [ 630, 1204, 1770, 2100]}, + { words =>3362, remainder => 0, ec => [ 660, 1260, 1860, 2220]}, + { words =>3532, remainder => 0, ec => [ 720, 1316, 1950, 2310]}, + { words =>3706, remainder => 0, ec => [ 750, 1372, 2040, 2430]}, + ) + ]; + + sub qrspec_data_size ($version, $level) { + my $item = $table->[$version - 1]; + return $item->{words} - $item->{ec}{$level}; + } + + sub qrspec_ecc_size ($version, $level) { + return $table->[$version - 1]{ec}{$level}; + } + + sub qrspec_remainder ($version) { $table->[$version - 1]{remainder} } + + sub qrspec_min_version ($size, $level) { + state $arefs = {}; + + # first run goes through all items in the table, so this function + # is inefficient if called once per process but gets better when it + # is used multiple times per process. + my $aref = $arefs->{$level} //= do { + [ map { $_->{words} - $_->{ec}{$level} } $table->@* ] + }; + + # do not bother looking for a version if none is possible + return if $size > $aref->[-1]; + + # binary search over $aref + my ($lo, $hi) = (0, $aref->$#*); + while ($lo < $hi) { + my $mi = int(($lo + $hi) / 2); + my $misz = $aref->[$mi]; + if ($misz < $size) { $lo = $mi + 1 } # move ahead + elsif ($misz == $size) { $lo = $hi = $mi } # exact match + else { $hi = $mi } # set upper limit + } + return $lo + 1; + } +} + +{ + state $table = { + numeric => '0001', + alphanumeric => '0010', + byte => '0100', + kanji => '1000', + eci => '0111', + structured_append => '0011', + fnc1_1 => '0101', + fnc1_2 => '1001', + terminator => '0000', + }; + sub qrspec_mode_indicator ($mode) { $table->{$mode} } +} + +{ + state $table = { + numeric => [10, 12, 14], + alphanumeric => [ 9, 11, 13], + byte => [ 8, 16, 16], + kanji => [ 8, 10, 12], + }; + + sub qrspec_min_version_for ($mode, $size, $level) { + state $size_bits_for = { + numeric => sub ($s) { 10 * int($s / 3) + [0, 4, 7]->[$s % 3] }, + alphanumeric => sub ($s) { 11 * int($s / 2) + 6 * ($s % 2) }, + byte => sub ($s) { return 8 * $s }, + kanji => sub ($s) { return 13 * $s }, + }; + + my $min_bits = 4 + $size_bits_for->{$mode}->($size); + my $lengths = $table->{$mode}; + for my $i (0 .. $lengths->$#*) { + my $n_bits = $min_bits + $lengths->[$i]; + my $rem = $n_bits % 8; + my $n_words = (($n_bits - $rem) / 8) + ($rem ? 1 : 0); + my $version = qrspec_min_version($n_words, $level); + return if !defined($version); + my $j = $version <= 9 ? 0 : $version <= 26 ? 1 : 2; + return $version if $i == $j; + } + return; + } + + sub qrspec_length_indicator ($mode, $version) { + my $l = $version <= 9 ? 0 : $version <= 26 ? 1 : 2; + return $table->{$mode}[$l]; + } + + sub qrspec_maximum_words ($mode, $version) { + my $l = $version <= 9 ? 0 : $version <= 26 ? 1 : 2; + my $bits = $table->{$mode}[$l]; + my $words = (1 << $bits) - 1; + $words *= 2 if $mode eq 'kanji'; + return $words; + } +} + +sub qrspec_format_pattern ($level, $mask_id) { + state $formats_for = { + L => [0x77c4, 0x72f3, 0x7daa, 0x789d, 0x662f, 0x6318, 0x6c41, 0x6976], + M => [0x5412, 0x5125, 0x5e7c, 0x5b4b, 0x45f9, 0x40ce, 0x4f97, 0x4aa0], + Q => [0x355f, 0x3068, 0x3f31, 0x3a06, 0x24b4, 0x2183, 0x2eda, 0x2bed], + H => [0x1689, 0x13be, 0x1ce7, 0x19d0, 0x0762, 0x0255, 0x0d0c, 0x083b], + }; + return $formats_for->{$level}[$mask_id]; +} + +sub qrspec_version_pattern ($version) { + state $version_pattern_for = [ + 0x07c94, 0x085bc, 0x09a99, 0x0a4d3, # 7-10 + 0x0bbf6, 0x0c762, 0x0d847, 0x0e60d, 0x0f928, # 11-15 + 0x10b78, 0x1145d, 0x12a17, 0x13532, 0x149a6, # 16-20 + 0x15683, 0x168c9, 0x177ec, 0x18ec4, 0x191e1, # 21-25 + 0x1afab, 0x1b08e, 0x1cc1a, 0x1d33f, 0x1ed75, # 26-30 + 0x1f250, 0x209d5, 0x216f0, 0x228ba, 0x2379f, # 31-35 + 0x24b0b, 0x2542e, 0x26a64, 0x27541, 0x28c69, # 36-40 + ]; + return $version <= 6 ? undef : $version_pattern_for->[$version - 7]; +} + +sub qrspec_alignment_patterns ($version) { + state $base = [ + [18 ], [22 ], [26 ], [30 ], # 2- 5 + [34 ], [22, 38], [24, 42], [26, 46], [28, 50], # 6-10 + [30, 54], [32, 58], [34, 62], [26, 46], [26, 48], # 11-15 + [26, 50], [30, 54], [30, 56], [30, 58], [34, 62], # 16-20 + [28, 50], [26, 50], [30, 54], [28, 54], [32, 58], # 21-25 + [30, 58], [34, 62], [26, 50], [30, 54], [26, 52], # 26-30 + [30, 56], [34, 60], [30, 58], [34, 62], [30, 54], # 31-35 + [24, 50], [28, 54], [32, 58], [26, 54], [30, 58], # 35-40 + ]; + state $cache = { 1 => [] }; + my $aref = $cache->{$version} //= do { + my @offset = (6, $base->[$version - 2]->@*); + my $width = qrspec_width($version); + while ('necessary') { + my $next = 2 * $offset[-1] - $offset[-2]; + last if $next + 2 >= $width; + push @offset, $next; + } + \@offset; + }; + return $aref->@*; +} + +sub _zip_hash ($aref1, $aref2) { + my %hash; + @hash{$aref1->@*} = $aref2->@*; + return \%hash; +} + +1; diff --git a/webmin/lang/en b/webmin/lang/en index 73a28d9af..cf55942ef 100644 --- a/webmin/lang/en +++ b/webmin/lang/en @@ -1209,6 +1209,7 @@ twofactor_enrolllink=You can now enroll for two-factor authentication in the $2. twofactor_etotpmodule=The Perl module $1 needed for two-factor authentication is not installed. Use the Perl Modules page in Webmin to install it. twofactor_qrcode=Enter the secret code $1 in the TOTP app, or scan the QR code below. +twofactor_qrcode_manual=Enter the secret code $1 in the TOTP app and set it up manually, as QR code generation is not supported on this system. twofactor_etotpid=Invalid TOTP base32-encoded secret twofactor_etotptoken=TOTP token must be a number twofactor_etotpmatch=Incorrect OTP code diff --git a/webmin/qr.cgi b/webmin/qr.cgi deleted file mode 100755 index b1d7d8d32..000000000 --- a/webmin/qr.cgi +++ /dev/null @@ -1,20 +0,0 @@ -#!/usr/local/bin/perl -# Show a QR code based on parameters - -use strict; -use warnings; -no warnings 'redefine'; -no warnings 'uninitialized'; -$main::no_acl_check = 1; -require './webmin-lib.pl'; - -our (%in, %text, %gconfig, %config); -&ReadParse(); -&error_setup($text{'qr_err'}); - -$in{'str'} || &error($text{'qr_estr'}); -my ($img, $mime) = &generate_qr_code($in{'str'}, $in{'size'}); -$img || &error($mime); - -&PrintHeader(undef, $mime); -print $img; diff --git a/webmin/twofactor-funcs-lib.pl b/webmin/twofactor-funcs-lib.pl index 8a62214d7..f6e3cfadf 100644 --- a/webmin/twofactor-funcs-lib.pl +++ b/webmin/twofactor-funcs-lib.pl @@ -224,55 +224,25 @@ sub message_twofactor_totp my ($user) = @_; my $name = &get_display_hostname()." (".$user->{'name'}.")"; my $str = "otpauth://totp/".$name."?secret=".$user->{'twofactor_id'}; -my $qrcode = &ui_tag('p', - &text('twofactor_qrcode', "$user->{'twofactor_id'}")); -if (&can_generate_qr()) { - my $url; - if (&get_product_name() eq 'usermin') { - $url = "qr.cgi?size=6"; - } - else { - $url = "$gconfig{'webprefix'}/webmin/qr.cgi?size=6"; - } - my $id = "twofactor_qr_".int(time())."_".int(rand(1000000)); +my ($qrimg, $mime) = &generate_qr_code($str, 6); +if ($qrimg) { + my $qrcode = &ui_tag('p', + &text('twofactor_qrcode', "$user->{'twofactor_id'}")); + my $src = "data:$mime;base64,".&encode_base64($qrimg, 'noeol'); my $img = &ui_tag('img', undef, - { 'id' => $id, 'border' => 0, - 'style' => 'width:210px; height:210px; '. + { 'src' => $src, 'border' => 0, + 'style' => 'width:180px; height:180px; '. 'border:1px solid #444;', 'alt' => 'QR code' }); - my $id_js = "e_javascript($id); - my $url_js = "e_javascript($url); - my $str_js = "e_javascript($str); return < -(function() { -const img = document.getElementById("$id_js"), - body = "str=" + encodeURIComponent("$str_js"); -fetch("$url_js", { - method: "POST", - body: body - }).then(function(response) { - if (!response.ok) { return null; } - return response.blob(); - }).then(function(blob) { - if (!blob) { return; } - const reader = new FileReader(); - reader.onloadend = function() { img.src = reader.result; }; - reader.readAsDataURL(blob); - }).catch(function() { }); -})(); - -

+ $qrcode$img

EOF } else { - my $url = "https://api.qrserver.com/v1/create-qr-code/?". - "size=200x200&data=".&urlize($str); - my $img = &ui_tag('img', undef, - { 'src' => $url, 'border' => 0, 'alt' => 'QR code' }); return < +

@{[ &text('twofactor_qrcode_manual', + "$user->{'twofactor_id'}") ]}

+

EOF } } @@ -361,18 +331,13 @@ if (!$found && $prov) { &unlock_file($miniserv->{'twofactorfile'}); } -# can_generate_qr() -# Returns 1 if QR codes can be generated on this system -sub can_generate_qr +# can_generate_qr_encoder() +# Returns 1 if the local QRCode::Encoder fallback can be used +sub can_generate_qr_encoder { -if (&has_command("qrencode")) { - return 1; - } -eval "use Image::PNG::QRCode"; -if (!$@) { - return 1; - } -return 0; +eval "use lib (\"$root_directory/vendor_perl\")"; +eval "use QRCode::Encoder qw(qr_encode)"; +return $@ ? 0 : 1; } # generate_qr_code(string, [block-size]) @@ -380,6 +345,10 @@ return 0; sub generate_qr_code { my ($str, $size) = @_; +if (&can_generate_qr_encoder()) { + my @rv = eval { &generate_qr_code_encoder($str, $size) }; + return @rv if (!$@ && defined($rv[0])); + } if (&has_command("qrencode")) { # Use the qrencode shell command my $cmd = "qrencode -o - -t PNG ".quotemeta($str); @@ -391,19 +360,43 @@ if (&has_command("qrencode")) { } return ($out, "image/png"); } -eval "use Image::PNG::QRCode"; -if (!$@) { - # Use a Perl module - my $out; - Image::PNG::QRCode::qrpng( - text => $str, - scale => $size || 6, - out => \$out, - ); - return ($out, "image/png"); - } return (undef, "QR code generation requires either the qrencode command or ". - "Image::PNG::QRCode Perl module"); + "QRCode::Encoder Perl module"); +} + +# generate_qr_code_encoder(string, [block-size]) +# Turn a string into a QR code SVG using the local QRCode::Encoder fallback +sub generate_qr_code_encoder +{ +my ($str, $size) = @_; +eval "use lib (\"$root_directory/vendor_perl\")"; +eval "use QRCode::Encoder qw(qr_encode)"; +if ($@) { + return (undef, "QR code generation requires the ". + "QRCode::Encoder Perl module"); + } +my $encoded = qr_encode($str, level => 'M'); +my $matrix = $encoded->{'matrix'}; +my $mod_size = $size || 6; +my $count = scalar(@$matrix); +my $dim = $count * $mod_size; +my $svg = qq{}; +$svg .= qq{}; +for my $y (0 .. $#$matrix) { + for my $x (0 .. $#{$matrix->[$y]}) { + if ($matrix->[$y][$x] & 1) { + my $px = $x * $mod_size; + my $py = $y * $mod_size; + $svg .= qq{}; + } + } + } +$svg .= ""; +return ($svg, "image/svg+xml"); } 1;