View | Details | Raw Unified | Return to bug 2500
Collapse All | Expand All

(-)a/C4/Labels/Label.pm (-26 / +20 lines)
Lines 6-11 use warnings; Link Here
6
use Text::Wrap;
6
use Text::Wrap;
7
use Algorithm::CheckDigits;
7
use Algorithm::CheckDigits;
8
use Text::CSV_XS;
8
use Text::CSV_XS;
9
use Data::Dumper;
9
10
10
use C4::Context;
11
use C4::Context;
11
use C4::Debug;
12
use C4::Debug;
Lines 133-141 sub _split_ddcn { Link Here
133
    $_ = $ddcn;
134
    $_ = $ddcn;
134
    s/\///g;   # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
135
    s/\///g;   # in theory we should be able to simply remove all segmentation markers and arrive at the correct call number...
135
    my (@parts) = m/
136
    my (@parts) = m/
136
        ^([a-zA-Z-]+(?:$possible_decimal)?) # R220.3            # BIO   # first example will require extra splitting
137
        ^([-a-zA-Z]*\s?(?:$possible_decimal)?) # R220.3  CD-ROM 787.87 # will require extra splitting
137
        \s+
138
        \s+
138
        (.+)                               # H2793Z H32 c.2   # R5c.1   # everything else (except bracketing spaces)
139
        (.+)                               # H2793Z H32 c.2 EAS # everything else (except bracketing spaces)
139
        \s*
140
        \s*
140
        /x;
141
        /x;
141
    unless (scalar @parts)  {
142
    unless (scalar @parts)  {
Lines 143-183 sub _split_ddcn { Link Here
143
        push @parts, $_;     # if no match, just push the whole string.
144
        push @parts, $_;     # if no match, just push the whole string.
144
    }
145
    }
145
146
146
    if ($parts[ 0] =~ /^([a-zA-Z]+)($possible_decimal)$/) {
147
    if ($parts[0] =~ /^([-a-zA-Z]+)\s?($possible_decimal)$/) {
147
          shift @parts;         # pull off the mathching first element, like example 1
148
          shift @parts;         # pull off the mathching first element, like example 1
148
        unshift @parts, $1, $2; # replace it with the two pieces
149
        unshift @parts, $1, $2; # replace it with the two pieces
149
    }
150
    }
150
151
151
    push @parts, split /\s+/, pop @parts;   # split the last piece into an arbitrary number of pieces at spaces
152
    push @parts, split /\s+/, pop @parts;   # split the last piece into an arbitrary number of pieces at spaces
152
153
    if ($parts[-1] !~ /^.*\d-\d.*$/ && $parts[-1] =~ /^(.*\d+)(\D.*)$/) {
154
         pop @parts;            # pull off the mathching last element, like example 2
155
        push @parts, $1, $2;    # replace it with the two pieces
156
    }
157
158
    $debug and print STDERR "split_ddcn array: ", join(" | ", @parts), "\n";
153
    $debug and print STDERR "split_ddcn array: ", join(" | ", @parts), "\n";
159
    return @parts;
154
    return @parts;
160
}
155
}
161
156
162
sub _split_fcn {
157
## NOTE: Custom call number types go here. It may be necessary to create additional splitting algorithms if some custom call numbers
158
##      cannot be made to work here. Presently this splits standard non-ddcn, non-lccn fiction and biography call numbers.
159
160
sub _split_ccn {
163
    my ($fcn) = @_;
161
    my ($fcn) = @_;
164
    my @fcn_split = ();
162
    my @parts = ();
165
    # Split fiction call numbers based on spaces
163
    # Split call numbers based on spaces
166
    SPLIT_FCN:
164
    push @parts, split /\s+/, $fcn;   # split the call number into an arbitrary number of pieces at spaces
167
    while ($fcn) {
165
    if ($parts[-1] !~ /^.*\d-\d.*$/ && $parts[-1] =~ /^(.*\d+)(\D.*)$/) {
168
        if ($fcn =~ m/([A-Za-z0-9]+\.?[0-9]?)(\W?).*?/x) {
166
        pop @parts;            # pull off the matching last element
169
            push (@fcn_split, $1);
167
        push @parts, $1, $2;    # replace it with the two pieces
170
            $fcn = $';
171
        }
172
        else {
173
            last SPLIT_FCN;     # No match, break out of the loop
174
        }
175
    }
168
    }
176
    unless (scalar @fcn_split) {
169
    unless (scalar @parts) {
177
        warn sprintf('regexp failed to match string: %s', $_);
170
        warn sprintf('regexp failed to match string: %s', $_);
178
        push (@fcn_split, $_);
171
        push (@parts, $_);
179
    }
172
    }
180
    return @fcn_split;
173
    $debug and print STDERR "split_ccn array: ", join(" | ", @parts), "\n";
174
    return @parts;
181
}
175
}
182
176
183
sub _get_barcode_data {
177
sub _get_barcode_data {
Lines 414-424 sub draw_label_text { Link Here
414
        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
408
        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
415
            if ($cn_source eq 'lcc') {
409
            if ($cn_source eq 'lcc') {
416
                @label_lines = _split_lccn($field_data);
410
                @label_lines = _split_lccn($field_data);
417
                @label_lines = _split_fcn($field_data) if !@label_lines;    # If it was not a true lccn, try it as a fiction call number
411
                @label_lines = _split_ccn($field_data) if !@label_lines;    # If it was not a true lccn, try it as a custom call number
418
                push (@label_lines, $field_data) if !@label_lines;         # If it was not that, send it on unsplit
412
                push (@label_lines, $field_data) if !@label_lines;         # If it was not that, send it on unsplit
419
            } elsif ($cn_source eq 'ddc') {
413
            } elsif ($cn_source eq 'ddc') {
420
                @label_lines = _split_ddcn($field_data);
414
                @label_lines = _split_ddcn($field_data);
421
                @label_lines = _split_fcn($field_data) if !@label_lines;
415
                @label_lines = _split_ccn($field_data) if !@label_lines;
422
                push (@label_lines, $field_data) if !@label_lines;
416
                push (@label_lines, $field_data) if !@label_lines;
423
            } else {
417
            } else {
424
                warn sprintf('Call number splitting failed for: %s. Please add this call number to bug #2500 at bugs.koha.org', $field_data);
418
                warn sprintf('Call number splitting failed for: %s. Please add this call number to bug #2500 at bugs.koha.org', $field_data);
(-)a/t/Labels_split_ccn.t (+63 lines)
Line 0 Link Here
1
#!/usr/bin/perl
2
#
3
# This file is part of Koha.
4
#
5
# Koha is free software; you can redistribute it and/or modify it under the
6
# terms of the GNU General Public License as published by the Free Software
7
# Foundation; either version 2 of the License, or (at your option) any later
8
# version.
9
#
10
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
11
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13
#
14
# You should have received a copy of the GNU General Public License along with
15
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
16
# Suite 330, Boston, MA  02111-1307 USA
17
#
18
# for context, see http://bugs.koha.org
19
20
use strict;
21
use warnings;
22
23
use Test::More;
24
25
BEGIN {
26
    our $ccns = {};
27
    if ($ARGV[0]) {
28
        BAIL_OUT("USAGE: perl Labels_split_ccn.t 'BIO JP2 R5c.1' 'BIO,JP2,R5c.1'") unless $ARGV[1];
29
        $ccns = {$ARGV[0] => [split (/,/,$ARGV[1])],};
30
    }
31
    else {
32
        $ccns = {
33
            'BIO JP2 R5c.1'         => [qw(BIO JP2 R5 c.1)],
34
            'FIC GIR J5c.1'         => [qw(FIC GIR J5 c.1)],
35
            'J DAR G7c.11'          => [qw( J  DAR G7 c.11)],
36
            'MP3-CD F PARKER'       => [qw(MP3-CD F PARKER)],
37
        };
38
    }
39
    my $test_num = 1;
40
    foreach (keys(%$ccns)) {
41
        my $split_num += scalar(@{$ccns->{$_}});
42
        $test_num += 2 * $split_num;
43
        $test_num += 4;
44
    }
45
    plan tests => $test_num;
46
    use_ok('C4::Labels::Label');
47
    use vars qw($ccns);
48
}
49
50
foreach my $ccn (sort keys %$ccns) {
51
    my (@parts, @expected);
52
    ok($ccn, "ddcn: $ccn");
53
    ok(@expected = @{$ccns->{$ccn}}, "split expected to produce " . scalar(@expected) . " pieces");
54
    ok(@parts = C4::Labels::Label::_split_ccn($ccn), "C4::Labels::Label::_split_ccn($ccn)");
55
    ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
56
    my $i = 0;
57
    foreach my $unit (@expected) {
58
        my $part;
59
        ok($part = $parts[$i], "($ccn)[$i] populated: " . (defined($part) ? $part : 'UNDEF'));
60
        ok((defined($part) and $part eq $unit),     "($ccn)[$i]   matches: $unit");
61
        $i++;
62
    }
63
}
(-)a/t/Labels_split_ddcn.t (-15 / +38 lines)
Lines 1-32 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
#
2
#
3
# This file is part of Koha.
4
#
5
# Koha is free software; you can redistribute it and/or modify it under the
6
# terms of the GNU General Public License as published by the Free Software
7
# Foundation; either version 2 of the License, or (at your option) any later
8
# version.
9
#
10
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
11
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13
#
14
# You should have received a copy of the GNU General Public License along with
15
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
16
# Suite 330, Boston, MA  02111-1307 USA
17
#
3
# for context, see http://bugs.koha.org
18
# for context, see http://bugs.koha.org
4
19
5
use strict;
20
use strict;
6
use warnings;
21
use warnings;
7
22
8
use Test::More tests => 82;
23
use Test::More;
9
24
10
BEGIN {
25
BEGIN {
11
    use_ok('C4::Labels');
26
    our $ddcns = {};
27
    if ($ARGV[0]) {
28
        BAIL_OUT("USAGE: perl Labels_split_ddcn.t '621.3828 J28l' '621.3828,J28l'") unless $ARGV[1];
29
        $ddcns = {$ARGV[0] => [split (/,/,$ARGV[1])],};
30
    }
31
    else {
32
        $ddcns = {
33
            'R220.3 H2793Z H32 c.2' => [qw(R 220.3 H2793Z H32 c.2)],
34
            'CD-ROM 787.87 EAS'     => [qw(CD-ROM 787.87 EAS)],
35
            '252.051 T147 v.1-2'    => [qw(252.051 T147 v.1-2)],
36
        };
37
    }
38
    my $test_num = 1;
39
    foreach (keys(%$ddcns)) {
40
        my $split_num += scalar(@{$ddcns->{$_}});
41
        $test_num += 2 * $split_num;
42
        $test_num += 4;
43
    }
44
    plan tests => $test_num;
45
    use_ok('C4::Labels::Label');
46
    use vars qw($ddcns);
12
}
47
}
13
ok(defined C4::Labels::split_ddcn, 'C4::Labels::split_ddcn defined');
14
15
my $ddcns = {
16
    'BIO JP2 R5c.1'         => [qw(BIO JP2 R5 c.1 )],
17
    'FIC GIR J5c.1'         => [qw(FIC GIR J5 c.1 )],
18
    'J DAR G7c.11'          => [qw( J  DAR G7 c.11)],
19
    'R220.3 H2793Z H32 c.2' => [qw(R 220.3 H2793Z H32 c.2)],
20
    'CD-ROM 787.87 EAS'     => [qw(CD-ROM 787.87 EAS)],
21
    'MP3-CD F PARKER'       => [qw(MP3-CD F PARKER)],
22
    '252.051 T147 v.1-2'    => [qw(252.051 T147 v.1-2)],
23
};
24
48
25
foreach my $ddcn (sort keys %$ddcns) {
49
foreach my $ddcn (sort keys %$ddcns) {
26
    my (@parts, @expected);
50
    my (@parts, @expected);
27
    ok($ddcn, "ddcn: $ddcn");
51
    ok($ddcn, "ddcn: $ddcn");
28
    ok(@expected = @{$ddcns->{$ddcn}}, "split expected to produce " . scalar(@expected) . " pieces");
52
    ok(@expected = @{$ddcns->{$ddcn}}, "split expected to produce " . scalar(@expected) . " pieces");
29
    ok(@parts = C4::Labels::split_ddcn($ddcn), "C4::Labels::split_ddcn($ddcn)");
53
    ok(@parts = C4::Labels::Label::_split_ddcn($ddcn), "C4::Labels::Label::_split_ddcn($ddcn)");
30
    ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
54
    ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
31
    my $i = 0;
55
    my $i = 0;
32
    foreach my $unit (@expected) {
56
    foreach my $unit (@expected) {
Lines 36-39 foreach my $ddcn (sort keys %$ddcns) { Link Here
36
        $i++;
60
        $i++;
37
    }
61
    }
38
}
62
}
39
(-)a/t/Labels_split_lccn.t (-11 / +38 lines)
Lines 1-28 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
#
2
#
3
# This file is part of Koha.
4
#
5
# Koha is free software; you can redistribute it and/or modify it under the
6
# terms of the GNU General Public License as published by the Free Software
7
# Foundation; either version 2 of the License, or (at your option) any later
8
# version.
9
#
10
# Koha is distributed in the hope that it will be useful, but WITHOUT ANY
11
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12
# A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13
#
14
# You should have received a copy of the GNU General Public License along with
15
# Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place,
16
# Suite 330, Boston, MA  02111-1307 USA
17
#
3
# for context, see http://bugs.koha.org/cgi-bin/bugzilla/show_bug.cgi?id=2691
18
# for context, see http://bugs.koha.org/cgi-bin/bugzilla/show_bug.cgi?id=2691
4
19
5
use strict;
20
use strict;
6
use warnings;
21
use warnings;
7
22
8
use Test::More tests => 44;
23
use Test::More;
9
24
10
BEGIN {
25
BEGIN {
11
    use_ok('C4::Labels');
26
    our $lccns = {};
27
    if ($ARGV[0]) {
28
        BAIL_OUT("USAGE: perl Labels_split_lccn.t 'HE 8700.7 .P6 T44 1983' 'HE,8700.7,.P6,T44,1983'") unless $ARGV[1];
29
        $lccns = {$ARGV[0] => [split (/,/,$ARGV[1])],};
30
    }
31
    else {
32
        $lccns = {
33
            'HE8700.7 .P6T44 1983' => [qw(HE 8700.7 .P6 T44 1983)],
34
            'BS2545.E8 H39 1996'   => [qw(BS 2545 .E8 H39 1996)],
35
            'NX512.S85 A4 2006'    => [qw(NX 512 .S85 A4 2006)],
36
        };
37
    }
38
    my $test_num = 1;
39
    foreach (keys(%$lccns)) {
40
        my $split_num += scalar(@{$lccns->{$_}});
41
        $test_num += 2 * $split_num;
42
        $test_num += 4;
43
    }
44
    plan tests => $test_num;
45
    use_ok('C4::Labels::Label');
46
    use vars qw($lccns);
12
}
47
}
13
ok(defined C4::Labels::split_lccn, 'C4::Labels::split_lccn defined');
14
15
my $lccns = {
16
    'HE8700.7 .P6T44 1983' => [qw(HE 8700.7 .P6 T44 1983)],
17
    'BS2545.E8 H39 1996'   => [qw(BS 2545 .E8 H39 1996)],
18
    'NX512.S85 A4 2006'    => [qw(NX 512 .S85 A4 2006)],
19
};
20
48
21
foreach my $lccn (sort keys %$lccns) {
49
foreach my $lccn (sort keys %$lccns) {
22
    my (@parts, @expected);
50
    my (@parts, @expected);
23
    ok($lccn, "lccn: $lccn");
51
    ok($lccn, "lccn: $lccn");
24
    ok(@expected = @{$lccns->{$lccn}}, "split expected to produce " . scalar(@expected) . " pieces");
52
    ok(@expected = @{$lccns->{$lccn}}, "split expected to produce " . scalar(@expected) . " pieces");
25
    ok(@parts = C4::Labels::split_lccn($lccn), "C4::Labels::split_lccn($lccn)");
53
    ok(@parts = C4::Labels::Label::_split_lccn($lccn), "C4::Labels::Label::_split_lccn($lccn)");
26
    ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
54
    ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
27
    my $i = 0;
55
    my $i = 0;
28
    foreach my $unit (@expected) {
56
    foreach my $unit (@expected) {
29
- 

Return to bug 2500