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 (+52 lines)
Line 0 Link Here
1
#!/usr/bin/perl
2
#
3
# for context, see http://bugs.koha.org
4
5
use strict;
6
use warnings;
7
8
use Test::More;
9
use Data::Dumper;
10
11
BEGIN {
12
    use_ok('C4::Labels::Label');
13
}
14
15
my $ccns = {};
16
17
if ($ARGV[0]) {
18
    BAIL_OUT("USAGE: perl Labels_split_ccn.t 'BIO JP2 R5c.1' 'BIO,JP2,R5c.1'") unless $ARGV[1];
19
    $ccns = {$ARGV[0] => [split (/,/,$ARGV[1])],};
20
}
21
else {
22
    $ccns = {
23
    'BIO JP2 R5c.1'         => [qw(BIO JP2 R5 c.1)],
24
    'FIC GIR J5c.1'         => [qw(FIC GIR J5 c.1)],
25
    'J DAR G7c.11'          => [qw( J  DAR G7 c.11)],
26
    'MP3-CD F PARKER'       => [qw(MP3-CD F PARKER)],
27
    };
28
}
29
30
my $test_num = 0;
31
foreach (keys(%$ccns)) {
32
    my $split_num += scalar(@{$ccns->{$_}});
33
    $test_num += 2 * $split_num;
34
    $test_num += 4;
35
}
36
37
plan tests => $test_num;
38
39
foreach my $ccn (sort keys %$ccns) {
40
    my (@parts, @expected);
41
    ok($ccn, "ddcn: $ccn");
42
    ok(@expected = @{$ccns->{$ccn}}, "split expected to produce " . scalar(@expected) . " pieces");
43
    ok(@parts = C4::Labels::Label::_split_ccn($ccn), "C4::Labels::Label::_split_ccn($ccn)");
44
    ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
45
    my $i = 0;
46
    foreach my $unit (@expected) {
47
        my $part;
48
        ok($part = $parts[$i], "($ccn)[$i] populated: " . (defined($part) ? $part : 'UNDEF'));
49
        ok((defined($part) and $part eq $unit),     "($ccn)[$i]   matches: $unit");
50
        $i++;
51
    }
52
}
(-)a/t/Labels_split_ddcn.t (-11 / +23 lines)
Lines 5-32 Link Here
5
use strict;
5
use strict;
6
use warnings;
6
use warnings;
7
7
8
use Test::More tests => 82;
8
use Test::More;
9
use Data::Dumper;
9
10
10
BEGIN {
11
BEGIN {
11
    use_ok('C4::Labels');
12
    use_ok('C4::Labels::Label');
12
}
13
}
13
ok(defined C4::Labels::split_ddcn, 'C4::Labels::split_ddcn defined');
14
14
15
my $ddcns = {
15
my $ddcns = {};
16
    'BIO JP2 R5c.1'         => [qw(BIO JP2 R5 c.1 )],
16
17
    'FIC GIR J5c.1'         => [qw(FIC GIR J5 c.1 )],
17
if ($ARGV[0]) {
18
    'J DAR G7c.11'          => [qw( J  DAR G7 c.11)],
18
    BAIL_OUT("USAGE: perl Labels_split_ddcn.t '621.3828 J28l' '621.3828,J28l'") unless $ARGV[1];
19
    $ddcns = {$ARGV[0] => [split (/,/,$ARGV[1])],};
20
}
21
else {
22
    $ddcns = {
19
    'R220.3 H2793Z H32 c.2' => [qw(R 220.3 H2793Z H32 c.2)],
23
    '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)],
24
    '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)],
25
    '252.051 T147 v.1-2'    => [qw(252.051 T147 v.1-2)],
23
};
26
    };
27
}
28
29
my $test_num = 0;
30
foreach (keys(%$ddcns)) {
31
    my $split_num += scalar(@{$ddcns->{$_}});
32
    $test_num += 2 * $split_num;
33
    $test_num += 4;
34
}
35
36
plan tests => $test_num;
24
37
25
foreach my $ddcn (sort keys %$ddcns) {
38
foreach my $ddcn (sort keys %$ddcns) {
26
    my (@parts, @expected);
39
    my (@parts, @expected);
27
    ok($ddcn, "ddcn: $ddcn");
40
    ok($ddcn, "ddcn: $ddcn");
28
    ok(@expected = @{$ddcns->{$ddcn}}, "split expected to produce " . scalar(@expected) . " pieces");
41
    ok(@expected = @{$ddcns->{$ddcn}}, "split expected to produce " . scalar(@expected) . " pieces");
29
    ok(@parts = C4::Labels::split_ddcn($ddcn), "C4::Labels::split_ddcn($ddcn)");
42
    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)));
43
    ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
31
    my $i = 0;
44
    my $i = 0;
32
    foreach my $unit (@expected) {
45
    foreach my $unit (@expected) {
Lines 36-39 foreach my $ddcn (sort keys %$ddcns) { Link Here
36
        $i++;
49
        $i++;
37
    }
50
    }
38
}
51
}
39
(-)a/t/Labels_split_lccn.t (-10 / +24 lines)
Lines 5-28 Link Here
5
use strict;
5
use strict;
6
use warnings;
6
use warnings;
7
7
8
use Test::More tests => 44;
8
use Test::More;
9
9
10
BEGIN {
10
BEGIN {
11
    use_ok('C4::Labels');
11
    use_ok('C4::Labels::Label');
12
}
12
}
13
ok(defined C4::Labels::split_lccn, 'C4::Labels::split_lccn defined');
14
13
15
my $lccns = {
14
my $lccns = {};
16
    'HE8700.7 .P6T44 1983' => [qw(HE 8700.7 .P6 T44 1983)],
15
17
    'BS2545.E8 H39 1996'   => [qw(BS 2545 .E8 H39 1996)],
16
if ($ARGV[0]) {
18
    'NX512.S85 A4 2006'    => [qw(NX 512 .S85 A4 2006)],
17
    BAIL_OUT("USAGE: perl Labels_split_lccn.t 'HE 8700.7 .P6 T44 1983' 'HE,8700.7,.P6,T44,1983'") unless $ARGV[1];
19
};
18
    $lccns = {$ARGV[0] => [split (/,/,$ARGV[1])],};
19
}
20
else {
21
    $lccns = {
22
        'HE8700.7 .P6T44 1983' => [qw(HE 8700.7 .P6 T44 1983)],
23
        'BS2545.E8 H39 1996'   => [qw(BS 2545 .E8 H39 1996)],
24
        'NX512.S85 A4 2006'    => [qw(NX 512 .S85 A4 2006)],
25
    };
26
}
27
28
my $test_num = 0;
29
foreach (keys(%$lccns)) {
30
    my $split_num += scalar(@{$lccns->{$_}});
31
    $test_num += 2 * $split_num;
32
    $test_num += 4;
33
}
34
plan tests => $test_num;
20
35
21
foreach my $lccn (sort keys %$lccns) {
36
foreach my $lccn (sort keys %$lccns) {
22
    my (@parts, @expected);
37
    my (@parts, @expected);
23
    ok($lccn, "lccn: $lccn");
38
    ok($lccn, "lccn: $lccn");
24
    ok(@expected = @{$lccns->{$lccn}}, "split expected to produce " . scalar(@expected) . " pieces");
39
    ok(@expected = @{$lccns->{$lccn}}, "split expected to produce " . scalar(@expected) . " pieces");
25
    ok(@parts = C4::Labels::split_lccn($lccn), "C4::Labels::split_lccn($lccn)");
40
    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)));
41
    ok(scalar(@expected) == scalar(@parts), sprintf("%d of %d pieces produced", scalar(@parts), scalar(@expected)));
27
    my $i = 0;
42
    my $i = 0;
28
    foreach my $unit (@expected) {
43
    foreach my $unit (@expected) {
29
- 

Return to bug 2500