[Koha-patches] [PATCH] Bug 2500 Correcting incorrect splitting of cutter numbers
Galen Charlton
gmcharlt at gmail.com
Tue Sep 15 03:14:04 CEST 2009
Hi Chris,
I'm getting errors in all three test scripts. Please fix so that the
tests pass cleanly and resubmit - I believe your test plans are not
taken the use_ok tests into account.
$ prove t/Labels_split_lccn.t
t/Labels_split_lccn.t .. 1/? # Looks like you planned 42 tests but ran 43.
t/Labels_split_lccn.t .. Dubious, test returned 255 (wstat 65280, 0xff00)
All 42 subtests passed
Test Summary Report
-------------------
t/Labels_split_lccn.t (Wstat: 65280 Tests: 43 Failed: 1)
Failed test: 43
Non-zero exit status: 255
Parse errors: Plan (1..42) must be at the beginning or end of the TAP output
Bad plan. You planned 42 tests but ran 43.
Files=1, Tests=43, 1 wallclock secs ( 0.03 usr 0.00 sys + 0.53 cusr
0.04 csys = 0.60 CPU)
Result: FAIL
$ prove t/Labels_split_ddcn.t
t/Labels_split_ddcn.t .. 1/? # Looks like you planned 34 tests but ran 35.
t/Labels_split_ddcn.t .. Dubious, test returned 255 (wstat 65280, 0xff00)
All 34 subtests passed
Test Summary Report
-------------------
t/Labels_split_ddcn.t (Wstat: 65280 Tests: 35 Failed: 1)
Failed test: 35
Non-zero exit status: 255
Parse errors: Plan (1..34) must be at the beginning or end of the TAP output
Bad plan. You planned 34 tests but ran 35.
Files=1, Tests=35, 0 wallclock secs ( 0.02 usr 0.00 sys + 0.52 cusr
0.05 csys = 0.59 CPU)
Result: FAIL
$ prove t/Labels_split_ccn.t
t/Labels_split_ccn.t .. 1/? # Looks like you planned 46 tests but ran 47.
t/Labels_split_ccn.t .. Dubious, test returned 255 (wstat 65280, 0xff00)
All 46 subtests passed
Test Summary Report
-------------------
t/Labels_split_ccn.t (Wstat: 65280 Tests: 47 Failed: 1)
Failed test: 47
Non-zero exit status: 255
Parse errors: Plan (1..46) must be at the beginning or end of the TAP output
Bad plan. You planned 46 tests but ran 47.
Files=1, Tests=47, 0 wallclock secs ( 0.03 usr 0.01 sys + 0.52 cusr
0.05 csys = 0.61 CPU)
Result: FAIL
Regards,
Galen
On Mon, Sep 14, 2009 at 11:57 AM, Chris Nighswonger
<cnighswonger at foundations.edu> wrote:
> This patch does two things to improve the call number splitting algorithms:
>
> 1. It makes changes to ensure that cutter numbers are split correctly in ddcns
>
> 2. It moves custom/fiction/biography call number splitting to a separate algorithm.
> Before they were incorrectly placed in ddcns.
>
> This patch also modifies the call number splitting tests to accept call numbers from the
> command line to allow quick testing of any give call number against a particular algorithm.
> ---
> C4/Labels/Label.pm | 46 ++++++++++++++++++------------------------
> t/Labels_split_ccn.t | 52 +++++++++++++++++++++++++++++++++++++++++++++++++
> t/Labels_split_ddcn.t | 34 +++++++++++++++++++++----------
> t/Labels_split_lccn.t | 33 ++++++++++++++++++++++--------
> 4 files changed, 119 insertions(+), 46 deletions(-)
> create mode 100755 t/Labels_split_ccn.t
>
> diff --git a/C4/Labels/Label.pm b/C4/Labels/Label.pm
> index 9cf5026..c3ef20b 100644
> --- a/C4/Labels/Label.pm
> +++ b/C4/Labels/Label.pm
> @@ -6,6 +6,7 @@ use warnings;
> use Text::Wrap;
> use Algorithm::CheckDigits;
> use Text::CSV_XS;
> +use Data::Dumper;
>
> use C4::Context;
> use C4::Debug;
> @@ -133,9 +134,9 @@ sub _split_ddcn {
> $_ = $ddcn;
> s/\///g; # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
> my (@parts) = m/
> - ^([a-zA-Z-]+(?:$possible_decimal)?) # R220.3 # BIO # first example will require extra splitting
> + ^([-a-zA-Z]*\s?(?:$possible_decimal)?) # R220.3 CD-ROM 787.87 # will require extra splitting
> \s+
> - (.+) # H2793Z H32 c.2 # R5c.1 # everything else (except bracketing spaces)
> + (.+) # H2793Z H32 c.2 EAS # everything else (except bracketing spaces)
> \s*
> /x;
> unless (scalar @parts) {
> @@ -143,41 +144,34 @@ sub _split_ddcn {
> push @parts, $_; # if no match, just push the whole string.
> }
>
> - if ($parts[ 0] =~ /^([a-zA-Z]+)($possible_decimal)$/) {
> + if ($parts[0] =~ /^([-a-zA-Z]+)\s?($possible_decimal)$/) {
> shift @parts; # pull off the mathching first element, like example 1
> unshift @parts, $1, $2; # replace it with the two pieces
> }
>
> push @parts, split /\s+/, pop @parts; # split the last piece into an arbitrary number of pieces at spaces
> -
> - if ($parts[-1] !~ /^.*\d-\d.*$/ && $parts[-1] =~ /^(.*\d+)(\D.*)$/) {
> - pop @parts; # pull off the mathching last element, like example 2
> - push @parts, $1, $2; # replace it with the two pieces
> - }
> -
> $debug and print STDERR "split_ddcn array: ", join(" | ", @parts), "\n";
> return @parts;
> }
>
> -sub _split_fcn {
> +## NOTE: Custom call number types go here. It may be necessary to create additional splitting algorithms if some custom call numbers
> +## cannot be made to work here. Presently this splits standard non-ddcn, non-lccn fiction and biography call numbers.
> +
> +sub _split_ccn {
> my ($fcn) = @_;
> - my @fcn_split = ();
> - # Split fiction call numbers based on spaces
> - SPLIT_FCN:
> - while ($fcn) {
> - if ($fcn =~ m/([A-Za-z0-9]+\.?[0-9]?)(\W?).*?/x) {
> - push (@fcn_split, $1);
> - $fcn = $';
> - }
> - else {
> - last SPLIT_FCN; # No match, break out of the loop
> - }
> + my @parts = ();
> + # Split call numbers based on spaces
> + push @parts, split /\s+/, $fcn; # split the call number into an arbitrary number of pieces at spaces
> + if ($parts[-1] !~ /^.*\d-\d.*$/ && $parts[-1] =~ /^(.*\d+)(\D.*)$/) {
> + pop @parts; # pull off the matching last element
> + push @parts, $1, $2; # replace it with the two pieces
> }
> - unless (scalar @fcn_split) {
> + unless (scalar @parts) {
> warn sprintf('regexp failed to match string: %s', $_);
> - push (@fcn_split, $_);
> + push (@parts, $_);
> }
> - return @fcn_split;
> + $debug and print STDERR "split_ccn array: ", join(" | ", @parts), "\n";
> + return @parts;
> }
>
> sub _get_barcode_data {
> @@ -414,11 +408,11 @@ sub draw_label_text {
> if ((grep {$field->{'code'} =~ m/$_/} @callnumber_list) and ($self->{'printing_type'} eq 'BIB') and ($self->{'callnum_split'})) { # If the field contains the call number, we do some sp
> if ($cn_source eq 'lcc') {
> @label_lines = _split_lccn($field_data);
> - @label_lines = _split_fcn($field_data) if !@label_lines; # If it was not a true lccn, try it as a fiction call number
> + @label_lines = _split_ccn($field_data) if !@label_lines; # If it was not a true lccn, try it as a custom call number
> push (@label_lines, $field_data) if !@label_lines; # If it was not that, send it on unsplit
> } elsif ($cn_source eq 'ddc') {
> @label_lines = _split_ddcn($field_data);
> - @label_lines = _split_fcn($field_data) if !@label_lines;
> + @label_lines = _split_ccn($field_data) if !@label_lines;
> push (@label_lines, $field_data) if !@label_lines;
> } else {
> warn sprintf('Call number splitting failed for: %s. Please add this call number to bug #2500 at bugs.koha.org', $field_data);
> diff --git a/t/Labels_split_ccn.t b/t/Labels_split_ccn.t
> new file mode 100755
> index 0000000..b4a4833
> --- /dev/null
> +++ b/t/Labels_split_ccn.t
> @@ -0,0 +1,52 @@
> +#!/usr/bin/perl
> +#
> +# for context, see http://bugs.koha.org
> +
> +use strict;
> +use warnings;
> +
> +use Test::More;
> +use Data::Dumper;
> +
> +BEGIN {
> + use_ok('C4::Labels::Label');
> +}
> +
> +my $ccns = {};
> +
> +if ($ARGV[0]) {
> + BAIL_OUT("USAGE: perl Labels_split_ccn.t 'BIO JP2 R5c.1' 'BIO,JP2,R5c.1'") unless $ARGV[1];
> + $ccns = {$ARGV[0] => [split (/,/,$ARGV[1])],};
> +}
> +else {
> + $ccns = {
> + 'BIO JP2 R5c.1' => [qw(BIO JP2 R5 c.1)],
> + 'FIC GIR J5c.1' => [qw(FIC GIR J5 c.1)],
> + 'J DAR G7c.11' => [qw( J DAR G7 c.11)],
> + 'MP3-CD F PARKER' => [qw(MP3-CD F PARKER)],
> + };
> +}
> +
> +my $test_num = 0;
> +foreach (keys(%$ccns)) {
> + my $split_num += scalar(@{$ccns->{$_}});
> + $test_num += 2 * $split_num;
> + $test_num += 4;
> +}
> +
> +plan tests => $test_num;
> +
> +foreach my $ccn (sort keys %$ccns) {
> + my (@parts, @expected);
> + ok($ccn, "ddcn: $ccn");
> + ok(@expected = @{$ccns->{$ccn}}, "split expected to produce " . scalar(@expected) . " pieces");
> + ok(@parts = C4::Labels::Label::_split_ccn($ccn), "C4::Labels::Label::_split_ccn($ccn)");
> + ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
> + my $i = 0;
> + foreach my $unit (@expected) {
> + my $part;
> + ok($part = $parts[$i], "($ccn)[$i] populated: " . (defined($part) ? $part : 'UNDEF'));
> + ok((defined($part) and $part eq $unit), "($ccn)[$i] matches: $unit");
> + $i++;
> + }
> +}
> diff --git a/t/Labels_split_ddcn.t b/t/Labels_split_ddcn.t
> index 26aad55..4789ce4 100755
> --- a/t/Labels_split_ddcn.t
> +++ b/t/Labels_split_ddcn.t
> @@ -5,28 +5,41 @@
> use strict;
> use warnings;
>
> -use Test::More tests => 82;
> +use Test::More;
> +use Data::Dumper;
>
> BEGIN {
> - use_ok('C4::Labels');
> + use_ok('C4::Labels::Label');
> }
> -ok(defined C4::Labels::split_ddcn, 'C4::Labels::split_ddcn defined');
>
> -my $ddcns = {
> - 'BIO JP2 R5c.1' => [qw(BIO JP2 R5 c.1 )],
> - 'FIC GIR J5c.1' => [qw(FIC GIR J5 c.1 )],
> - 'J DAR G7c.11' => [qw( J DAR G7 c.11)],
> +my $ddcns = {};
> +
> +if ($ARGV[0]) {
> + BAIL_OUT("USAGE: perl Labels_split_ddcn.t '621.3828 J28l' '621.3828,J28l'") unless $ARGV[1];
> + $ddcns = {$ARGV[0] => [split (/,/,$ARGV[1])],};
> +}
> +else {
> + $ddcns = {
> 'R220.3 H2793Z H32 c.2' => [qw(R 220.3 H2793Z H32 c.2)],
> 'CD-ROM 787.87 EAS' => [qw(CD-ROM 787.87 EAS)],
> - 'MP3-CD F PARKER' => [qw(MP3-CD F PARKER)],
> '252.051 T147 v.1-2' => [qw(252.051 T147 v.1-2)],
> -};
> + };
> +}
> +
> +my $test_num = 0;
> +foreach (keys(%$ddcns)) {
> + my $split_num += scalar(@{$ddcns->{$_}});
> + $test_num += 2 * $split_num;
> + $test_num += 4;
> +}
> +
> +plan tests => $test_num;
>
> foreach my $ddcn (sort keys %$ddcns) {
> my (@parts, @expected);
> ok($ddcn, "ddcn: $ddcn");
> ok(@expected = @{$ddcns->{$ddcn}}, "split expected to produce " . scalar(@expected) . " pieces");
> - ok(@parts = C4::Labels::split_ddcn($ddcn), "C4::Labels::split_ddcn($ddcn)");
> + ok(@parts = C4::Labels::Label::_split_ddcn($ddcn), "C4::Labels::Label::_split_ddcn($ddcn)");
> ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
> my $i = 0;
> foreach my $unit (@expected) {
> @@ -36,4 +49,3 @@ foreach my $ddcn (sort keys %$ddcns) {
> $i++;
> }
> }
> -
> diff --git a/t/Labels_split_lccn.t b/t/Labels_split_lccn.t
> index 1893e9d..bf333e6 100755
> --- a/t/Labels_split_lccn.t
> +++ b/t/Labels_split_lccn.t
> @@ -5,24 +5,39 @@
> use strict;
> use warnings;
>
> -use Test::More tests => 44;
> +use Test::More;
>
> BEGIN {
> - use_ok('C4::Labels');
> + use_ok('C4::Labels::Label');
> }
> -ok(defined C4::Labels::split_lccn, 'C4::Labels::split_lccn defined');
>
> -my $lccns = {
> - 'HE8700.7 .P6T44 1983' => [qw(HE 8700.7 .P6 T44 1983)],
> - 'BS2545.E8 H39 1996' => [qw(BS 2545 .E8 H39 1996)],
> - 'NX512.S85 A4 2006' => [qw(NX 512 .S85 A4 2006)],
> -};
> +my $lccns = {};
> +
> +if ($ARGV[0]) {
> + BAIL_OUT("USAGE: perl Labels_split_lccn.t 'HE 8700.7 .P6 T44 1983' 'HE,8700.7,.P6,T44,1983'") unless $ARGV[1];
> + $lccns = {$ARGV[0] => [split (/,/,$ARGV[1])],};
> +}
> +else {
> + $lccns = {
> + 'HE8700.7 .P6T44 1983' => [qw(HE 8700.7 .P6 T44 1983)],
> + 'BS2545.E8 H39 1996' => [qw(BS 2545 .E8 H39 1996)],
> + 'NX512.S85 A4 2006' => [qw(NX 512 .S85 A4 2006)],
> + };
> +}
> +
> +my $test_num = 0;
> +foreach (keys(%$lccns)) {
> + my $split_num += scalar(@{$lccns->{$_}});
> + $test_num += 2 * $split_num;
> + $test_num += 4;
> +}
> +plan tests => $test_num;
>
> foreach my $lccn (sort keys %$lccns) {
> my (@parts, @expected);
> ok($lccn, "lccn: $lccn");
> ok(@expected = @{$lccns->{$lccn}}, "split expected to produce " . scalar(@expected) . " pieces");
> - ok(@parts = C4::Labels::split_lccn($lccn), "C4::Labels::split_lccn($lccn)");
> + ok(@parts = C4::Labels::Label::_split_lccn($lccn), "C4::Labels::Label::_split_lccn($lccn)");
> ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
> my $i = 0;
> foreach my $unit (@expected) {
> --
> 1.6.0.4
>
> _______________________________________________
> Koha-patches mailing list
> Koha-patches at lists.koha.org
> http://lists.koha.org/mailman/listinfo/koha-patches
>
--
Galen Charlton
gmcharlt at gmail.com
More information about the Koha-patches
mailing list