Make it possible to specify only a stem with optional trailing colon

ctfliblime · Oct 20, 2011 · 6489286 · 6489286
1 parent e298ec8
commit 6489286
Show file tree

Hide file tree

Showing 4 changed files with 38 additions and 8 deletions.
diff --git a/lib/Text/SuDocs.pm b/lib/Text/SuDocs.pm
@@ -2,6 +2,8 @@ package Text::SuDocs;
 
 # ABSTRACT: parse and normalize SuDocs numbers
 
+use 5.10.0;
+
 use Any::Moose;
 use namespace::autoclean;
 use Carp;
@@ -54,9 +56,10 @@ sub parse {
     $original = uc $original;
     $original =~ s{^\s+|\s+$}{}g;
     $original =~ s{\s+}{ }g;
+    $original =~ s{:$}{};
 
-    if ($original ~~ [qw(XJH XJS)]) {
-      $self->agency($original);
+    if ($original =~ /^(XJH|XJS)$/) {
+      $self->agency($1);
       return $self;
     }
 
@@ -65,8 +68,8 @@ sub parse {
         (\p{IsDigit}+)\s*\.\s*                    #Subagency
         (?:(\p{IsAlpha}+)\s+)?                    #Committee
         (\p{IsDigit}+)                            #Series
-        (?:/(\p{IsAlnum}+)(-\p{IsAlnum}+)?)?\s*:\s*  #RelSeries
-        (.*)                                      #Document
+        (?:/(\p{IsAlnum}+)(-\p{IsAlnum}+)?)?\s*   #RelSeries
+        (?::\s*(.*))?$                            #Document
         }x;
     croak 'Unable to determine stem' if (!($1 && $2 && $4));
 
@@ -87,7 +90,7 @@ sub normal_string {
     my $self = shift;
     my %args = (ref $_[0]) ? %{$_[0]} : @_;
 
-    return $self->agency if ($self->agency ~~ [qw(XJH XJS)]);
+    return $self->agency if ($self->agency =~ /^(?:XJH|XJS)$/);
 
     my $sudocs = sprintf(
         '%s %d.%s%s%s',
@@ -97,7 +100,8 @@ sub normal_string {
         $self->series,
         ($self->relatedseries) ? '/'.$self->relatedseries : '',
         );
-    unless ($args{class_stem}) {
+
+    unless ($args{class_stem} || !$self->document) {
         $sudocs .= ':'.$self->document;
     }
     return $sudocs;

diff --git a/t/003-fails.t b/t/003-fails.t
@@ -12,7 +12,6 @@ BEGIN {
 
 my @fail_strings = (
     'EP 1 998',
-    'EP 1.998',
     'EP 1 998:',
     'EP 1.998/:',
     '1.998:',
@@ -22,6 +21,8 @@ my @fail_strings = (
     'PR EX 28.8:C 76',
     'A 13.1/-2:P',
     'Y 3.P31:16/123',
+    'Y 3.P 31 ASDF',
+    'Y 3.P 31 1234',
     );
 subtest 'These strings should fail' => sub {
     map { dies_ok {Text::SuDocs->new($_)} "Intentional fail on bad string '$_'" } @fail_strings;

diff --git a/t/004-normal.t b/t/004-normal.t
@@ -100,12 +100,36 @@ my @accurate_strings = (
      agency=>'HE', subagency=>'1', series=>'2',
      relatedseries=>undef, document=>'AC 6/7'},
 
+    {original=>'A 3.103:',
+     sortable=>'A_00000003.00000103',
+     normal=>'A 3.103', stem=>'A 3.103',
+     agency=>'A', subagency=>'3', series=>'103',
+     relatedseries=>undef, document=>undef},
+
+    {original=>'A 3.103',
+     sortable=>'A_00000003.00000103',
+     normal=>'A 3.103', stem=>'A 3.103',
+     agency=>'A', subagency=>'3', series=>'103',
+     relatedseries=>undef, document=>undef},
+
     {original=>'XJH',
      sortable=>'XJH',
      normal=>'XJH', stem=>'XJH',
      agency=>'XJH', subagency=>undef, series=>undef,
      relatedseries=>undef, document=>undef},
 
+    {original=>'XJH:',
+     sortable=>'XJH',
+     normal=>'XJH', stem=>'XJH',
+     agency=>'XJH', subagency=>undef, series=>undef,
+     relatedseries=>undef, document=>undef},
+
+    {original=>'  XJH: ',
+     sortable=>'XJH',
+     normal=>'XJH', stem=>'XJH',
+     agency=>'XJH', subagency=>undef, series=>undef,
+     relatedseries=>undef, document=>undef},
+
     {original=>'   XJH    ',
      sortable=>'XJH',
      normal=>'XJH', stem=>'XJH',

diff --git a/t/010-bulk.t b/t/010-bulk.t
@@ -12,12 +12,13 @@ my @samples = <DATA>;
 for (@samples) {
     chomp;
     my $s = new_ok('Text::SuDocs' => [$_], $_);
-    is(uc($_), $s->normal_string);
+    is($s->normal_string, uc($_));
 }
 
 done_testing();
 
 __DATA__
+A 3.103
 HE 20.8315:1
 HE 20.8315:2
 HE 20.8315:3