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

(-)a/C4/ClassSortRoutine/Generic.pm (-5 / +64 lines)
Lines 1-6 Link Here
1
package C4::ClassSortRoutine::Generic;
1
package C4::ClassSortRoutine::Generic;
2
2
3
# Copyright (C) 2007 LibLime
3
# Copyright (C) 2007 LibLime, 2026 Rijksmuseum
4
#
4
#
5
# This file is part of Koha.
5
# This file is part of Koha.
6
#
6
#
Lines 20-26 package C4::ClassSortRoutine::Generic; Link Here
20
use strict;
20
use strict;
21
use warnings;
21
use warnings;
22
22
23
=head1 NAME 
23
=head1 NAME
24
24
25
C4::ClassSortRoutine::Generic - generic call number sorting key routine
25
C4::ClassSortRoutine::Generic - generic call number sorting key routine
26
26
Lines 51-62 sub get_class_sort_key { Link Here
51
    $cn_class = '' unless defined $cn_class;
51
    $cn_class = '' unless defined $cn_class;
52
    $cn_item  = '' unless defined $cn_item;
52
    $cn_item  = '' unless defined $cn_item;
53
    my $key = uc "$cn_class $cn_item";
53
    my $key = uc "$cn_class $cn_item";
54
    $key =~ s/^\s+//;
54
55
    $key =~ s/\s+$//;
55
    # Remove leading/trailing spaces, then zero pad
56
    # Then replace spaces and remove 'cruft'
57
    $key =~ s/^\s+|\s+$//g;
58
    $key = _zero_pad_callnum($key);
56
    $key =~ s/\s+/_/g;
59
    $key =~ s/\s+/_/g;
57
    $key =~ s/[^\p{IsAlnum}_]//g;
60
    $key =~ s/[^\p{IsAlnum}_]//g;
61
58
    return $key;
62
    return $key;
63
}
64
65
=head2 _zero_pad_callnum
66
67
    Optionally zero pad numeric parts of a call number with zeroes
68
    based on the preference ClassSortGenericFormats.
59
69
70
    That pref may contain multiple formats separated by ';;'.
71
    A format has an optional filter (regex) followed by a colon, and a
72
    list of pairs of two numbers (separated by commas). The two numbers
73
    represent a minimum number of digits to find and the length to pad.
74
    So e.g. 1,4;2,3 means find at least 1 digit and pad to 4 positions,
75
    then find at least 2 digits and pad to 3 positions.
76
    If a format leads to a match, the remaining formats are skipped. So,
77
    the order of the formats matters.
78
    See also t/ClassSortRoutine_Generic.t for some examples.
79
80
=cut
81
82
sub _zero_pad_callnum {
83
    my $key = shift;
84
    return if !defined($key);
85
    my $pref = C4::Context->preference('ClassSortGenericFormats') or return $key;
86
    foreach my $format ( split /;;/, $pref ) {
87
88
        # a format has an optional filter and a list of min,padlength pairs
89
        my ( $filter, $pairs ) =
90
            $format =~ /:/
91
            ? split /:/, $format, 2
92
            : ( q{}, $format );
93
        if ($filter) {
94
            my $test = eval { $key =~ /$filter/ ? 1 : 0 };
95
            warn "Pref ClassSortGenericFormats has bad filter: $filter\n" if !defined $test;    # regex failed
96
            next                                                          if !$test;
97
        }
98
99
        my @pairs = map { my $p = $_; $p =~ s/\s*//g; $p } map { split /,/, $_, 2 } split /;/, $pairs;
100
        if ( @pairs % 2 > 0 || grep { /\D|^0?$/ } @pairs ) {
101
102
            # We expect: even number, only digits, not zero or empty
103
            warn "Pref ClassSortGenericFormats has bad format: $format\n";
104
            next;
105
        }
106
107
        my ( $new_key, $pos, $digits ) = ( q{}, 0 );
108
        foreach ( my $j = 0 ; $j < @pairs ; $j += 2 ) {
109
            if ( $pairs[$j] && substr( $key, $pos ) =~ /(\d{$pairs[$j],})/ ) {
110
                $pos += $-[0] + length($1);
111
                $digits = $pairs[ $j + 1 ];
112
                $new_key .= $` . sprintf( "%0${digits}d", $1 );
113
                return $new_key . substr( $key, $pos ) if $j + 2 >= @pairs;
114
            } else {
115
                last;
116
            }
117
        }
118
    }
119
    return $key;
60
}
120
}
61
121
62
1;
122
1;
Lines 66-69 sub get_class_sort_key { Link Here
66
Koha Development Team <https://koha-community.org/>
126
Koha Development Team <https://koha-community.org/>
67
127
68
=cut
128
=cut
69
(-)a/t/ClassSortRoutine_Generic.t (-17 / +69 lines)
Lines 1-25 Link Here
1
#!/usr/bin/perl
1
#!/usr/bin/perl
2
#
3
# This Koha test module is a stub!
4
# Add more tests here!!!
5
6
use strict;
7
use warnings;
8
2
3
use Modern::Perl;
4
use Test::More tests => 3;
9
use Test::NoWarnings;
5
use Test::NoWarnings;
10
use Test::More tests => 4;
6
use Test::Warn;
7
use t::lib::Mocks;
8
use C4::ClassSortRoutine::Generic qw( get_class_sort_key );
9
10
subtest 'class_sort_key' => sub {
11
    t::lib::Mocks::mock_preference( 'ClassSortGenericFormats', q{} );
12
13
    my $cn_class = "My class ";
14
    my $cn_item  = " hellO";
15
16
    my $cn_sort = C4::ClassSortRoutine::Generic::get_class_sort_key( $cn_class, $cn_item );
17
    is( $cn_sort, "MY_CLASS_HELLO", "testing cnsort" );
18
19
    $cn_sort = C4::ClassSortRoutine::Generic::get_class_sort_key();
20
    is( $cn_sort, "", "Testing with undef" );
21
22
    $cn_sort = C4::ClassSortRoutine::Generic::get_class_sort_key(' 1 A 2 ');
23
    is( $cn_sort, '1_A_2', 'Removed leading and trailing whitespace' );
24
};
25
26
subtest '_zero_pad_callnum' => sub {
27
    t::lib::Mocks::mock_preference( 'ClassSortGenericFormats', '\s[A-Z]\s:1,4;1,3' );
28
29
    # Trivial tests
30
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum(),    undef );
31
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum(q{}), q{} );
32
33
    # Filter does not match
34
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('1 @ 2'), '1 @ 2' );
11
35
12
BEGIN {
36
    # Format does not match (no two digit groups)
13
    use_ok('C4::ClassSortRoutine::Generic');
37
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('2 T (a)'), '2 T (a)' );
14
}
15
38
16
my $cn_class = "My class ";
39
    # Matching (two) digit groups
17
my $cn_item  = " hellO";
40
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('0 A 23 test 45'),           '0000 A 023 test 45' );
41
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('12 A 234 test 456'),        '0012 A 234 test 456' );
42
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('123 A 1234 test 3456'),     '0123 A 1234 test 3456' );
43
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('1234 A 12345 test 34567'),  '1234 A 12345 test 34567' );
44
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('12345 A 12345 test 34567'), '12345 A 12345 test 34567' );
18
45
19
my $cn_sort = C4::ClassSortRoutine::Generic::get_class_sort_key( $cn_class, $cn_item );
46
    # Invalid filter, invalid format (zero or empty string, no semicolon)
47
    t::lib::Mocks::mock_preference( 'ClassSortGenericFormats', '^BC):1,4;1,3' );
48
    my $result;
49
    warning_like { $result = C4::ClassSortRoutine::Generic::_zero_pad_callnum('BC 11 A 2') }
50
    qr/bad filter/, 'Got a warn about bad filter';
51
    is( $result, 'BC 11 A 2' );
52
    t::lib::Mocks::mock_preference( 'ClassSortGenericFormats', '^BC:1,4;0,3' );
53
    warning_like { $result = C4::ClassSortRoutine::Generic::_zero_pad_callnum('BC 11 A 2') }
54
    qr/bad format/, 'Got a warn about bad format';
55
    is( $result, 'BC 11 A 2' );
56
    t::lib::Mocks::mock_preference( 'ClassSortGenericFormats', '^BC:1,4;,3' );
57
    warning_like { $result = C4::ClassSortRoutine::Generic::_zero_pad_callnum('BC 11 A 2') }
58
    qr/bad format/, 'Got a warn about bad format';
59
    is( $result, 'BC 11 A 2' );
60
    t::lib::Mocks::mock_preference( 'ClassSortGenericFormats', '^BC:2,4,1,3' );
61
    warning_like { $result = C4::ClassSortRoutine::Generic::_zero_pad_callnum('BC 11 A 2') }
62
    qr/bad format/, 'Got a warn about bad format';
63
    is( $result, 'BC 11 A 2' );
20
64
21
is( $cn_sort, "MY_CLASS_HELLO", "testing cnsort" );
65
    # Correct the format
66
    t::lib::Mocks::mock_preference( 'ClassSortGenericFormats', '^BC: 2,4; 1,3' );
67
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('BC 11 A 2'), 'BC 0011 A 002' );
22
68
23
$cn_sort = C4::ClassSortRoutine::Generic::get_class_sort_key( undef, undef );
69
    # First digit group too short, last group not included in format
70
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('BC 1 22 A 3 4'), 'BC 1 0022 A 003 4' );
24
71
25
is( $cn_sort, "", "Testing blank cnsort" );
72
    # More formats (hitting each one once, and finally no one)
73
    t::lib::Mocks::mock_preference( 'ClassSortGenericFormats', '^BC:2,4;2,3;;^B:2,3;;1,2;1,2;1,2' );
74
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('BC 11 A 22'), 'BC 0011 A 022' );
75
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('BC 11 A 2'),  'BC 011 A 2' );
76
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('BC 1 A 2 3'), 'BC 01 A 02 03' );
77
    is( C4::ClassSortRoutine::Generic::_zero_pad_callnum('BC 1 A 2 X'), 'BC 1 A 2 X' );
78
};
26
- 

Return to bug 41932