Library-CallNumber-LC-0.23000755001750001750 012442626007 17534 5ustar00libsys-adminlibsys-admin000000000000Library-CallNumber-LC-0.23/META.json000444001750001750 205212442626007 21311 0ustar00libsys-adminlibsys-admin000000000000{ "abstract" : "Deal with Library-of-Congress call numbers", "author" : [ "Daniel Wells " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.110440", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Library-CallNumber-LC", "prereqs" : { "build" : { "requires" : { "Math::BigInt" : 0, "Test::More" : 0 } }, "configure" : { "requires" : { "Module::Build" : "0.38" } }, "runtime" : { "requires" : { "Math::BigInt" : 0 } } }, "provides" : { "Library::CallNumber::LC" : { "file" : "lib/Library/CallNumber/LC.pm", "version" : "0.23" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.23" } Library-CallNumber-LC-0.23/Makefile.PL000444001750001750 61412442626007 21624 0ustar00libsys-adminlibsys-admin000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.3800 use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'Library::CallNumber::LC', 'VERSION_FROM' => 'lib/Library/CallNumber/LC.pm', 'PREREQ_PM' => { 'Math::BigInt' => 0, 'Test::More' => 0 }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {} ) ; Library-CallNumber-LC-0.23/MANIFEST000444001750001750 21712442626007 21002 0ustar00libsys-adminlibsys-admin000000000000Build.PL Changes MANIFEST README lib/Library/CallNumber/LC.pm t/00-load.t t/01-basics.t t/t_Labels_split_lccn.t Makefile.PL META.yml META.json Library-CallNumber-LC-0.23/META.yml000444001750001750 115012442626007 21137 0ustar00libsys-adminlibsys-admin000000000000--- abstract: 'Deal with Library-of-Congress call numbers' author: - 'Daniel Wells ' build_requires: Math::BigInt: 0 Test::More: 0 configure_requires: Module::Build: 0.38 dynamic_config: 1 generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.110440' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Library-CallNumber-LC provides: Library::CallNumber::LC: file: lib/Library/CallNumber/LC.pm version: 0.23 requires: Math::BigInt: 0 resources: license: http://dev.perl.org/licenses/ version: 0.23 Library-CallNumber-LC-0.23/README000444001750001750 320412442626007 20550 0ustar00libsys-adminlibsys-admin000000000000Library-CallNumber-LC Library::CallNumber::LC is mostly designed to do call number normalization, with the following goals: * The normalized call numbers are comparable with each other, for proper sorting * The normalized call number is a short as possible, so left-anchored wildcard searches are possible (e.g., searching on "A11*" should give you all the A11 call numbers) * A range defined by start_of_range and end_of_range should be correct, assuming that the string given for the end of the range is, in fact, a left prefix. Given the nature of generating normalized sort keys, compatibility between versions is NOT a goal, as any bug-fixes or features will likely require changing the key format. INSTALLATION To install this module, run the following commands: perl Build.PL ./Build ./Build test ./Build install SUPPORT AND DOCUMENTATION After installing, you can find documentation for this module with the perldoc command. perldoc Library::CallNumber::LC You can also look for information at: Google code repository http://code.google.com/p/library-callnumber-lc/ RT, CPAN's request tracker http://rt.cpan.org/NoAuth/Bugs.html?Dist=Library-CallNumber-LC AnnoCPAN, Annotated CPAN documentation http://annocpan.org/dist/Library-CallNumber-LC CPAN Ratings http://cpanratings.perl.org/d/Library-CallNumber-LC Search CPAN http://search.cpan.org/dist/Library-CallNumber-LC COPYRIGHT AND LICENCE Copyright (C) 2011 Dan Wells Copyright (C) 2009 Bill Dueber This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Library-CallNumber-LC-0.23/Build.PL000444001750001750 106412442626007 21166 0ustar00libsys-adminlibsys-admin000000000000use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'Library::CallNumber::LC', license => 'perl', dist_author => 'Daniel Wells ', dist_version_from => 'lib/Library/CallNumber/LC.pm', requires => { 'Math::BigInt' => 0, }, build_requires => { 'Test::More' => 0, 'Math::BigInt' => 0, }, add_to_cleanup => [ 'Library-CallNumber-LC-*' ], create_makefile_pl => 'traditional', ); $builder->create_build_script(); Library-CallNumber-LC-0.23/Changes000444001750001750 261312442626007 21166 0ustar00libsys-adminlibsys-admin000000000000Revision history for Library-CallNumber-LC 0.23 2014/12/12 -Don't uppercase the callnumber on input -Make the first cutter decimal optional (see new test case) 0.22 2012/05/01 -Clarify licensing (both same-as-Perl and BSD) 0.21 2012/05/01 -Correct deprecated use of qw(...) as parentheses 0.20 2011/07/19 -Move from fixed to variable length normalization. This helps: -Fix 2-digit decimal limitation (now unlimited) -Sort cutters properly when number of digits exceeds 4 (now unlimited) -Overall 27% reduction in sort-key length, on average -Improved sorting of numbers in "extra" field -Properly recognize numbers which subdivide a class -(e.g. BX830 1545 .M3) -Make characters used to force items up or down in the sort order configurable (defaults to SPACE and TILDE) -Add accessor for changing call number text in object instances 0.10 2009/07/08 Added "toLongInt" for possible use in a Trie field in Solr Added third argument to _normalize to force full-length range-start normalization (for use in above) 0.02 2009/03/20 Added method #components to return matched components in an array; suggested by Joe Atzberger on #code4lib 0.01 2009/03/18 First version, released on an unsuspecting world. Library-CallNumber-LC-0.23/t000755001750001750 012442626007 17777 5ustar00libsys-adminlibsys-admin000000000000Library-CallNumber-LC-0.23/t/01-basics.t000444001750001750 667612442626007 22022 0ustar00libsys-adminlibsys-admin000000000000#!perl -T use Library::CallNumber::LC; use Test::More qw(no_plan); use Math::BigInt; my $a = Library::CallNumber::LC->new('A'); is($a->normalize, 'A', "Basic normalization"); is($a->normalize, $a->start_of_range, "Equvalent functions"); is($a->end_of_range, 'A~', "End of range"); $a->call_number('B11 A543'); is($a->normalize, 'B0011 A543', "Change call number"); is($a->call_number, 'B11 A543', "Retrieve call number text"); is($a->topper, ' ', "Retrieve 'topper'"); is($a->bottomer, '~', "Retrieve 'bottomer'"); my $LC = Library::CallNumber::LC->new(); is($LC->normalize('A11.1'), 'A00111', "Basic normalization"); is($LC->end_of_range('A11.1'), 'A00111~', "End of range"); is($a->normalize('B11'), 'B0011', "Passed in arg"); is($a->normalize('A 123.4 .c11'), 'A01234 C11', "Cutter"); is($a->normalize('B11 A543 B6'), 'B0011 A543 B6', "Two cutters"); is($a->start_of_range('B11 .c13 .d11'), 'B0011 C13 D11', "Two cutters start"); is($a->end_of_range('B11 .c13 .d11'), 'B0011 C13 D11~', "Two cutters end"); # try some alternate sort chars # instance level $a->topper('!'); $a->bottomer('_'); is($a->normalize('A0610.5 C75 M5'), 'A06105!C75!M5', "Instance level 'topper' setting"); is($a->end_of_range('A610.5'), 'A06105_', "Instance level 'bottomer' setting"); # instance level at construction my $b = Library::CallNumber::LC->new('A123 C44', '$', ']'); is($b->end_of_range, 'A0123$C44]', "Instance level 'topper'/'bottomer'"); # class level Library::CallNumber::LC->topper('#'); Library::CallNumber::LC->bottomer('^'); is(Library::CallNumber::LC->normalize('A0610.5 C75 M5'), 'A06105#C75#M5', "Class level 'topper' setting"); is(Library::CallNumber::LC->end_of_range('A610.5'), 'A06105^', "Class level 'bottomer' setting"); # reset back to defaults Library::CallNumber::LC->topper(' '); Library::CallNumber::LC->bottomer('~'); $a->topper(' '); $a->bottomer('~'); is($a->normalize('A0610.5 C75 M5'), 'A06105 C75 M5', "Instance level 'topper' setting"); is(Library::CallNumber::LC->normalize('A0610.5 C75 M5'), 'A06105 C75 M5', "Class level 'topper' setting"); my @test = ( "a 0", "a 1 1923", "a 8 f166", "a19 f96", "a19f99g15", "a19 .f99 g15 1997", "a242 83 i65", "a610 h18", "a610.5 c75 m5 1910", "a610.8 e8f 0", "a610.9 c27pr 0", "a610.9 c38tr 0", "a610.9 f16", "a610.9 g38n 0", "a610.9 m96", "a612.601 c8", "a614.2 f36", "a614.4972 c12 es 0", "a615.1 n84", "a615.11 f23", "a615.3 s68pl 0", "a615.7 o5l 0", "a618.2 l58n 0", "a618.2 r7g 0", "a820.3 b 0", "aa 0", "aa39", "aa102 ottawapt 1-final 0", "ab 0", "abc 0", "ac 1 a52", "ac 1 a671 2000", "ac 1 a6713 2000", "ac 1 a926 r 0", "ac 1 b26", "ac 1 c2", "ac 1 c212", "ac 1 e45", "ac 1 f142", "ac 1 g78", "hd205 1974.m3", "hd205 1974.m83", "hd205 1974 .s74", "tk5105.87 .g57 1993", "tk5105.875 .i57 c92 2005", "tk5105.888 .s43 1997", "zzz19f99g15", "zzz 1945 f99g15 d11 1990", ); my @testints; foreach my $t (@test) { my $l = $a->toLongInt($t); next unless ($l); push @testints, Math::BigInt->new($l); } for ($j = 0; $j < scalar(@test) -1; $j++) { my $n1 = $a->normalize($test[$j]); my $n2 = $a->normalize($test[$j+1]); my $i1 = new Math::BigInt $a->toLongInt($test[$j]); my $i2 = new Math::BigInt $a->toLongInt($test[$j+1]); next unless ($n1 and $n2); # skip the invalids ok($n1 lt $n2, $test[$j] . ' < ' . $test[$j+1] . ' (normalize)'); # must allow "or equal" due to lack of precision ok($i1->bcmp($i2) <= 0, $test[$j] . ' < ' . $test[$j+1] . " (toLongInt $i1 vs $i2)"); } Library-CallNumber-LC-0.23/t/t_Labels_split_lccn.t000444001750001750 156312442626007 24265 0ustar00libsys-adminlibsys-admin000000000000#!/usr/bin/perl # # for context, see http://bugs.koha.org/cgi-bin/bugzilla/show_bug.cgi?id=2691 use strict; use warnings; use Test::More tests => 26; use Library::CallNumber::LC; 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)], 'J 295.435 K56' => [qw(J 295.435 K56)], }; foreach my $lccn (sort keys %$lccns) { my @expected = @{$lccns->{$lccn}}; my @parts = Library::CallNumber::LC->new($lccn)->components; ok($lccn, "lccn: $lccn (" . join(" | ", @parts) . ')'); is(scalar(@parts), scalar(@expected), "$lccn: Correctly produced " . scalar(@expected) . " parts"); my $i = 0; foreach my $unit (@expected) { is($parts[$i], $unit, "$lccn: Correctly matched $unit at position $i"); $i++; } } Library-CallNumber-LC-0.23/t/00-load.t000444001750001750 26312442626007 21436 0ustar00libsys-adminlibsys-admin000000000000#!perl -T use Test::More tests => 1; BEGIN { use_ok( 'Library::CallNumber::LC' ); } diag( "Testing Library::CallNumber::LC $Library::CallNumber::LC::VERSION, Perl $], $^X" ); Library-CallNumber-LC-0.23/lib000755001750001750 012442626007 20302 5ustar00libsys-adminlibsys-admin000000000000Library-CallNumber-LC-0.23/lib/Library000755001750001750 012442626007 21706 5ustar00libsys-adminlibsys-admin000000000000Library-CallNumber-LC-0.23/lib/Library/CallNumber000755001750001750 012442626007 23732 5ustar00libsys-adminlibsys-admin000000000000Library-CallNumber-LC-0.23/lib/Library/CallNumber/LC.pm000444001750001750 3375212442626007 24755 0ustar00libsys-adminlibsys-admin000000000000package Library::CallNumber::LC; use warnings; use strict; use Math::BigInt; =head1 NAME Library::CallNumber::LC - Deal with Library-of-Congress call numbers =head1 VERSION Version 0.23; =cut our $VERSION = '0.23'; =head1 SYNOPSIS Utility functions to deal with Library of Congress Call Numbers use Library::CallNumber::LC; my $a = Library::CallNumber::LC->new('A 123.4 .c11'); print $a->normalize; # normalizes for string comparisons. # gives 'A01234 C11' print $a->start_of_range; # same as "normalize" my $b = Library::CallNumber::LC->new('B11 .c13 .d11'); print $b->normalize; # gives 'B0011 C13 D11' my @range = ($a->start_of_range, $b->end_of_range); # end of range is 'B0011 C13 D11~' # Get components suitable for printing (e.g., number and decimal joined, leading dot on first cutter) @comps = Library::CallNumber::LC->new('A 123.4 .c11')->components() # Same thing, but return empty strings for missing components (e.g., the cutters) @comps = Library::CallNumber::LC->new('A 123.4 .c11')->components('true'); =head1 ABSTRACT Library::CallNumber::LC is mostly designed to do call number normalization, with the following goals: =over 4 =item * The normalized call numbers are comparable with each other, for proper sorting =item * The normalized call number is a short as possible, so left-anchored wildcard searches are possible (e.g., searching on "A11*" should give you all the A11 call numbers) =item * A range defined by start_of_range and end_of_range should be correct, assuming that the string given for the end of the range is, in fact, a left prefix. =back That last point needs some explanation. The idea is that if someone gives a range of, say, A-AZ, what they really mean is A - AZ9999.99. The end_of_range method generates a key which lies immediately beyond the last possible key for a given starting point. There is no attempt to make end_of_range normalization correspond to anything in real life. =cut # Set up the prefix mapping for longints my %intmap; my $i = 0; foreach my $prefix (qw(a aa ab abc ac ae ag ah ai al am an anl ao ap aq arx as at aug aw awo ay az b bc bd bf bg bh bj bl bm bn bp bq br bs bt bu bv bx c cb cc cd ce cg cis cj cmh cmm cn cr cs ct cz d da daa daw db dc dd de df dff dg dh dj djk dk dkj dl doc dp dq dr ds dt dth du dx e ea eb ec ed ee ek ep epa ex f fb fc fem fg fj fnd fp fsd ft ful g ga gb gc gda ge gf gh gn gr gs gt gv h ha hb hc hcg hd he hf hfs hg hh hhg hj hjc hm hmk hn hq hs ht hv hx i ia ib iid ill ilm in ioe ip j ja jan jb jc jf jg jh jhe jj jk jkc jl jln jn jq js jv jx jz k kb kbm kbp kbq kbr kbu kc kd kdc kde kdg kdk kds kdz ke kea keb kem ken keo keq kes kf kfa kfc kfd kff kfg kfh kfi kfk kfl kfm kfn kfo kfp kfr kfs kft kfu kfv kfw kfx kfz kg kga kgb kgc kgd kge kgf kgg kgh kgj kgk kgl kgn kgq kgs kgt kgv kgx kh kha khc khd khf khh khk khp khq khu khw kit kj kja kjc kje kjg kjj kjk kjm kjn kjp kjq kjr kjs kjt kjv kjw kk kka kkb kkc kke kkf kkg kkh kki kkj kkm kkn kkp kkq kkr kks kkt kkv kkw kkx kky kkz kl kla klb kld kle klf klg klh klm kln klp klr kls klt klv klw km kmc kme kmf kmh kmj kmk kml kmm kmn kmo kmp kmq kmt kmu kmv kmx kn knc knd kne knf kng knh knk knl knm knn knp knq knr kns knt knu knw knx kny kp kpa kpc kpe kpf kpg kph kpj kpk kpl kpm kpp kps kpt kpv kpw kq kqc kqe kqg kqj kqk kqp kqw krb krc krg krm krn krp krr krs kru krv krx ks ksa ksc ksh ksj ksk ksl ksp kss kst ksv ksw ksx ksy kta ktd ktg ktj ktk ktl ktq ktr ktt ktu ktv ktw ktx kty ktz ku kuc kuq kvc kvf kvm kvn kvp kvq kvr kvs kvw kwc kwg kwh kwl kwp kwr kww kwx kz kza kzd l la law lb lc ld le lf lg lh lj ll ln lrm lt lv m may mb mc me mf mh mkl ml mpc mr ms mt my n na nat nax nb nc nd nda nds ne ner new ng nh nk nl nmb nn no nt nv nx ok onc p pa pb pc pcr pd pe pf pg ph phd pj pjc pk pl pm pn pnb pp pq pr ps pt pz q qa qb qc qd qe qh qk ql qm qp qr qry qu qv r ra rb rbw rc rcc rd re ref res rf rg rh rj rk rl rm rn rp rs rt rv rx rz s sb sd see sf sfk sgv sh sk sn sql sw t ta tc td tdd te tf tg tgg th tj tk tl tn tnj to tp tr ts tt tx tz u ua ub uc ud ue uf ug uh un use v va vb vc vd ve vf vg vk vla vm w wq x xp xx y yh yl yy z za zhn zz zzz)) { $intmap{$prefix} = $i; $i++; } # Regexp constants to deal with matching LC and variants my $lcregex = qr/^ \s* (?:VIDEO-D)? # for video stuff (?:DVD-ROM)? # DVDs, obviously (?:CD-ROM)? # CDs (?:TAPE-C)? # Tapes \s* ([A-Z]{1,3}) # alpha \s* (?: # optional numbers with optional decimal point (\d+) (?:\s*?\.\s*?(\d+))? )? \s* (\d+[stndrh]*)? # optional extra numbering including suffixes (1st, 2nd, etc.) \s* (?: # optional cutter (\.)? \s* # optional decimal ([A-Z]) # cutter letter \s* (\d+ | \Z)? # cutter numbers )? \s* (?: # optional cutter \.? \s* ([A-Z]) # cutter letter \s* (\d+ | \Z)? # cutter numbers )? \s* (?: # optional cutter \.? \s* ([A-Z]) # cutter letter \s* (\d+ | \Z)? # cutter numbers )? (\s+.+?)? # everthing else \s*$ /x; my $weird = qr/ ^ \s*[A-Z]+\s*\d+\.\d+\.\d+ /x; # Class variables for top/bottom sort chars my $Topper = ' '; # must sort before 'A' my $Bottomer = '~'; # must sort after 'Z' and '9' =head1 CONSTRUCTORS =head2 new([call_number_text, [topper_character, [bottomer_character]]]) -- create a new object, optionally passing in the initial string, a "topper", and a "bottomer" (explained below) =cut sub new { my $proto = shift; my $class = ref($proto) || $proto; my $lc = shift || ''; my $topper = shift; $topper = $Topper if !defined($topper); # ZERO is false but might be a reasonable value, so we need this more specific check my $bottomer = shift || $Bottomer; my $self = { callno => $lc, topper => $topper, bottomer => $bottomer }; bless $self, $class; return $self; } =head1 BASIC ACCESSORS =head2 call_number([call_number_text]) The text of the call number we are dealing with. =cut sub call_number { my $self = shift; if (@_) { $self->{callno} = uc(shift) } return $self->{callno}; } =head2 topper([character]) Specify which character occupies the 'always-sort-to-the-top' slots in the sort keys. Defaults to the SPACE character, but can reasonably be anything with an ASCII value lower than 48 (i.e. the 'zero' character, '0'). This can function as either a class or instance method depending on need. =cut sub topper { my $self = shift; my $topper = shift; if (ref $self) { $self->{topper} = $topper if $topper; # just myself return $self->{topper}; } else { $Topper = $topper if $topper; # whole class return $Topper; } } =head2 bottomer([character]) Specify which character occupies the 'always-sort-to-the-bottom' slots in the sort keys. Defaults to the TILDE character, but can reasonably be anything with an ASCII value higher than 90 (i.e. 'Z'). This can function as either a class or instance method depending on need. =cut sub bottomer { my $self = shift; my $bottomer = shift; if (ref $self) { $self->{bottomer} = $bottomer if $bottomer; # just myself return $self->{bottomer}; } else { $Bottomer = $bottomer if $bottomer; # whole class return $Bottomer; } } =head1 OTHER METHODS =head2 components(boolean returnAll = false) @comps = Library::CallNumber::LC->new('A 123.4 .c11')->components($returnAll) Returns an array of the individual components of the call number (or undef if it doesn't look like a call number). Components are: =over 4 =item * alpha =item * number (numeric.decimal) =item * cutter1 =item * cutter2 =item * cutter3 =item * "extra" (anything after the cutters) =back The optional argument (false by default) determines whether or not empty components (e.g., extra cutters) get a slot in the returned list. =cut sub components { my $self = shift; my $returnAll = shift; my $lc = $self->{callno}; return undef if ($lc =~ $weird); return undef unless ($lc =~ $lcregex); my ($alpha, $num, $dec, $othernum, $c1dec, $c1alpha, $c1num, $c2alpha, $c2num, $c3alpha, $c3num, $extra) = ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12); #combine stuff if need be if ($dec) { $num .= '.' . $dec; } no warnings; my $c1 = join('', $c1alpha, $c1num); my $c2 = join('', $c2alpha, $c2num); my $c3 = join('', $c3alpha, $c3num); use warnings; $c1 = '.' . $c1 if $c1dec; my @return; foreach my $comp ($alpha, $num, $othernum, $c1, $c2, $c3, $extra) { $comp = '' unless (defined $comp); next unless ($comp =~ /\S/ or $returnAll); $comp =~ m/^\s*(.*?)\s*$/; $comp = $1; push @return, $comp; } return @return; } =head2 _normalize(call_number_text) Base function to perform normalization. =cut sub _normalize { my $self = shift; my $lc = uc(shift); my $topper = $self->topper; # return undef if ($lc =~ $weird); return undef unless ($lc =~ $lcregex); my ($alpha, $num, $dec, $othernum, $c1dec, $c1alpha, $c1num, $c2alpha, $c2num, $c3alpha, $c3num, $extra) = ($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12); no warnings; my $class = $alpha; $class .= sprintf('%04s', $num) if $num; $class .= $dec if $dec; my $c1 = $c1alpha.$c1num; my $c2 = $c2alpha.$c2num; my $c3 = $c3alpha.$c3num; # normalize extra (most commonly years/numbering, benefits from padding) # this could be reduced to a four digit pad, as very, very few numbers # reach 10000, but we'll be conservative here (for now) $extra =~ s/^\s+//g; $extra =~ s/\.\s+/./g; $extra =~ s/(\d)\s*-\s*(\d)/$1-$2/g; $extra =~ s/(\d+)/sprintf("%05s", $1)/ge; $extra = $topper . $extra if ($extra ne ''); # give the extra less 'weight' for falling down the list # pad out othernum (again, conservatively) $othernum =~ s/(\d+)/sprintf("%05s", $1)/ge; return join($topper, grep {/\S/} ($class, $othernum, $c1, $c2, $c3, $extra)); } =head2 normalize([call_number_text]) Normalize the stored or passed call number as a sortable string =cut sub normalize { my $self = shift; my $lc = shift; $lc = $lc? uc($lc) : $self->{callno}; return $self->_normalize($lc) } =head2 start_of_range([call_number_text]) Alias for normalize =cut sub start_of_range { my $self = shift; return $self->normalize(@_); } =head2 end_of_range([call_number_text]) Downshift an lc number so it represents the end of a range =cut sub end_of_range { my $self = shift; my $lc = shift; $lc = $lc? uc($lc) : $self->{callno}; my $bottomer = $self->bottomer; return $self->_normalize($lc) . $bottomer; } =head2 toLongInt(call_number_text, num_digits) Attempt to turn a call number into an integer value. Possibly useful for fast range checks, although obviously not perfectly accurate. Optional argument I<$num_digits> can be used to control the number of digits used, and therefore the precision of the results. =cut my $minval = new Math::BigInt('0'); # set to zero until this code matures my $minvalstring = $minval->bstr; # this is a work in progress, with room for improvement in both exception # logic and overall economy of bits sub toLongInt { my $self = shift; my $lc = shift; my $num_digits = shift || 19; # 19 is a max-fit for 64-bits within our scope my $topper = $self->topper; my $bottomer = $self->bottomer; #print "$lc\n"; my $topper_ord = ord($topper); my $long = $self->normalize($lc); return $minvalstring unless ($long); my ($alpha, $num, $rest); if ($long =~ /^([A-Z]+)(\d{4})(.*)$/) { # we have a 'full' call number ($alpha, $num, $rest) = (lc($1), $2, $3); } elsif ($long =~ /^([A-Z]+)(.*)$/) { # numberless class; generally invalid, but let it slide for now ($alpha, $rest) = (lc($1), $2); if ($rest =~ /^$bottomer/) { # bottomed-out class $num = '9999'; } else { $num = '0000'; } } my $class_int_string = ''; if (defined($intmap{$alpha})) { $class_int_string .= $intmap{$alpha} . $num; } else { warn "Unknown prefix '$alpha'\n"; return $minvalstring; } my $rest_int_string = ''; my $bottomout; foreach my $char (split('', $rest)) { if ($char eq $bottomer) { $bottomout = 1; last; } $rest_int_string .= sprintf('%02d', ord($char) - $topper_ord); } $rest_int_string = substr($rest_int_string, 0, $num_digits - 7); # Reserve first seven digits for $alpha and $num if ($bottomout) { $rest_int_string .= '9' x (($num_digits - 7) - length($rest_int_string)); # pad it if need be } else { $rest_int_string .= '0' x (($num_digits - 7) - length($rest_int_string)); # pad it if need be } # print " $long => ", join('', @rv), "\n"; my $longint = Math::BigInt->new($class_int_string . $rest_int_string); $longint->badd($minval); # warn "\n\n".$self->_normalize($lc)." = ".$longint->bstr." ( $class_int_string + $rest_int_string) \n\n"; return $longint->bstr; } =head1 AUTHOR Current Maintainer: Dan Wells, C<< >> Original Author: Bill Dueber, C<< >> =head1 BUGS Please report any bugs or feature requests through the web interface at L. I will be notified, and then you'll automatically be notified of progress on your bug as I make changes. =head1 SUPPORT You can find documentation for this module with the perldoc command. perldoc Library::CallNumber::LC You can also look for information at the Google Code page: http://code.google.com/p/library-callnumber-lc/ =head1 COPYRIGHT & LICENSE Copyright 2009 Bill Dueber, all rights reserved. Copyright 2011 Dan Wells, all rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself and also under the new BSD license as described at http://www.opensource.org/licenses/bsd-license.php =cut 1; # End of Library::CallNumber::LC