| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package CTK::Digest::M11R; | 
| 2 | 1 |  |  | 1 |  | 55578 | use strict; | 
|  | 1 |  |  |  |  | 7 |  | 
|  | 1 |  |  |  |  | 23 |  | 
| 3 | 1 |  |  | 1 |  | 465 | use utf8; | 
|  | 1 |  |  |  |  | 12 |  | 
|  | 1 |  |  |  |  | 4 |  | 
| 4 |  |  |  |  |  |  |  | 
| 5 |  |  |  |  |  |  | =encoding utf-8 | 
| 6 |  |  |  |  |  |  |  | 
| 7 |  |  |  |  |  |  | =head1 NAME | 
| 8 |  |  |  |  |  |  |  | 
| 9 |  |  |  |  |  |  | CTK::Digest::M11R - interface for modulus 11 (recursive) check digit calculation | 
| 10 |  |  |  |  |  |  |  | 
| 11 |  |  |  |  |  |  | =head1 VERSION | 
| 12 |  |  |  |  |  |  |  | 
| 13 |  |  |  |  |  |  | Version 1.01 | 
| 14 |  |  |  |  |  |  |  | 
| 15 |  |  |  |  |  |  | =head1 SYNOPSIS | 
| 16 |  |  |  |  |  |  |  | 
| 17 |  |  |  |  |  |  | use CTK::Digest::M11R; | 
| 18 |  |  |  |  |  |  | my $m11r = CTK::Digest::M11R->new(); | 
| 19 |  |  |  |  |  |  | my $digest = $m11r->digest( "123456789" ); # 5 | 
| 20 |  |  |  |  |  |  |  | 
| 21 |  |  |  |  |  |  | =head1 DESCRIPTION | 
| 22 |  |  |  |  |  |  |  | 
| 23 |  |  |  |  |  |  | This is Digest backend module that provides calculate the modulus 11 (recursive) check digit | 
| 24 |  |  |  |  |  |  |  | 
| 25 |  |  |  |  |  |  | =head1 METHODS | 
| 26 |  |  |  |  |  |  |  | 
| 27 |  |  |  |  |  |  | =head2 digest | 
| 28 |  |  |  |  |  |  |  | 
| 29 |  |  |  |  |  |  | my $digest = $m11r->digest( "123456789" ); # 5 | 
| 30 |  |  |  |  |  |  |  | 
| 31 |  |  |  |  |  |  | Returns M11R checkdigit by specified digits-string | 
| 32 |  |  |  |  |  |  |  | 
| 33 |  |  |  |  |  |  | =head1 HISTORY | 
| 34 |  |  |  |  |  |  |  | 
| 35 |  |  |  |  |  |  | See C file | 
| 36 |  |  |  |  |  |  |  | 
| 37 |  |  |  |  |  |  | =head1 TO DO | 
| 38 |  |  |  |  |  |  |  | 
| 39 |  |  |  |  |  |  | See C file | 
| 40 |  |  |  |  |  |  |  | 
| 41 |  |  |  |  |  |  | =head1 BUGS | 
| 42 |  |  |  |  |  |  |  | 
| 43 |  |  |  |  |  |  | * none noted | 
| 44 |  |  |  |  |  |  |  | 
| 45 |  |  |  |  |  |  | =head1 SEE ALSO | 
| 46 |  |  |  |  |  |  |  | 
| 47 |  |  |  |  |  |  | L, L, B | 
| 48 |  |  |  |  |  |  |  | 
| 49 |  |  |  |  |  |  | =head1 AUTHOR | 
| 50 |  |  |  |  |  |  |  | 
| 51 |  |  |  |  |  |  | Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE | 
| 52 |  |  |  |  |  |  |  | 
| 53 |  |  |  |  |  |  | =head1 COPYRIGHT | 
| 54 |  |  |  |  |  |  |  | 
| 55 |  |  |  |  |  |  | Copyright (C) 1998-2022 D&D Corporation. All Rights Reserved | 
| 56 |  |  |  |  |  |  |  | 
| 57 |  |  |  |  |  |  | =head1 LICENSE | 
| 58 |  |  |  |  |  |  |  | 
| 59 |  |  |  |  |  |  | This program is free software; you can redistribute it and/or | 
| 60 |  |  |  |  |  |  | modify it under the same terms as Perl itself. | 
| 61 |  |  |  |  |  |  |  | 
| 62 |  |  |  |  |  |  | See C file and L | 
| 63 |  |  |  |  |  |  |  | 
| 64 |  |  |  |  |  |  | =cut | 
| 65 |  |  |  |  |  |  |  | 
| 66 | 1 |  |  | 1 |  | 36 | use vars qw/ $VERSION /; | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 67 |  | 
| 67 |  |  |  |  |  |  | $VERSION = 1.01; | 
| 68 |  |  |  |  |  |  |  | 
| 69 | 1 |  |  | 1 |  | 5 | use Carp; | 
|  | 1 |  |  |  |  | 1 |  | 
|  | 1 |  |  |  |  | 42 |  | 
| 70 |  |  |  |  |  |  |  | 
| 71 | 1 |  |  | 1 |  | 330 | use parent qw/CTK::Digest/; | 
|  | 1 |  |  |  |  | 253 |  | 
|  | 1 |  |  |  |  | 4 |  | 
| 72 |  |  |  |  |  |  |  | 
| 73 |  |  |  |  |  |  | sub digest { | 
| 74 |  |  |  |  |  |  | # See also: Algorithm::CheckDigits::M11_015 and check_okpo() | 
| 75 | 1 |  |  | 1 | 1 | 4 | my $self = shift; | 
| 76 | 1 |  |  |  |  | 2 | my $data = shift; | 
| 77 | 1 | 50 |  |  |  | 3 | $self->{data} = $data if defined $data; | 
| 78 | 1 |  |  |  |  | 2 | my $test = $self->{data}; | 
| 79 | 1 | 50 | 33 |  |  | 7 | croak "Incorrect input digit-string" if !$test || $test =~ m/[^0-9]/g; | 
| 80 | 1 |  |  |  |  | 2 | my $len = length($test); | 
| 81 | 1 | 50 |  |  |  | 5 | my $iters = ($len + (($len & 1) ? 1 : 0)) / 2; | 
| 82 | 1 |  |  |  |  | 6 | my @digits = split(//, $test); # Get all digits from input string of chars | 
| 83 |  |  |  |  |  |  | #printf "Test=%s; len=%d; iters=%d\n", $test, $len, $iters; | 
| 84 |  |  |  |  |  |  |  | 
| 85 | 1 |  |  |  |  | 1 | my $w_lim = 10; # Maximum for round-robin(10) weight list: 1,2,3,4,5,6,7,8,9,10,1,2,3,4,5... | 
| 86 | 1 |  |  |  |  | 2 | my $step = 2; # Step for weight list offset calculation for next iteration | 
| 87 |  |  |  |  |  |  |  | 
| 88 |  |  |  |  |  |  | # Calculation sum for one weight list by ofset | 
| 89 |  |  |  |  |  |  | my $calc = sub { | 
| 90 | 3 |  | 100 | 3 |  | 6 | my $off = shift || 0; | 
| 91 | 3 |  |  |  |  | 4 | my $s = 0; | 
| 92 | 3 |  |  |  |  | 4 | for (my $i = 0; $i < $len; $i++) { | 
| 93 | 27 |  |  |  |  | 30 | my $w = (($i + $off) % $w_lim) + 1; | 
| 94 | 27 |  |  |  |  | 38 | $s += ($w * $digits[$i]); | 
| 95 |  |  |  |  |  |  | #printf " > i=%d; d=%d; w=%d; sum=%d\n", $i, $digits[$i], $w, $s; | 
| 96 |  |  |  |  |  |  | } | 
| 97 | 3 |  |  |  |  | 4 | return $s % 11; | 
| 98 | 1 |  |  |  |  | 4 | }; | 
| 99 |  |  |  |  |  |  |  | 
| 100 |  |  |  |  |  |  | # Main cycle | 
| 101 | 1 |  |  |  |  | 2 | my $sum = 0; | 
| 102 | 1 |  |  |  |  | 4 | for (my $j = 0; $j < $iters; $j++) { | 
| 103 | 3 |  |  |  |  | 4 | my $offset = $j*$step; | 
| 104 | 3 |  |  |  |  | 4 | $sum = $calc->($offset); | 
| 105 |  |  |  |  |  |  | #printf " >> j=%d; offset=%d; sum=%d\n", $j, $offset, $sum; | 
| 106 | 3 | 100 |  |  |  | 9 | last if $sum < 10; | 
| 107 |  |  |  |  |  |  | } | 
| 108 | 1 | 50 |  |  |  | 3 | $sum = 0 if $sum >= 10; # 0 if incorrect again | 
| 109 |  |  |  |  |  |  | #printf " >>> sum=%d\n", $sum; | 
| 110 |  |  |  |  |  |  |  | 
| 111 | 1 |  |  |  |  | 7 | return $sum; | 
| 112 |  |  |  |  |  |  | } | 
| 113 |  |  |  |  |  |  |  | 
| 114 |  |  |  |  |  |  | 1; | 
| 115 |  |  |  |  |  |  |  | 
| 116 |  |  |  |  |  |  | __END__ |