Equinox-Migration/lib/Equinox/Migration/SimpleTagList.pm

   1 package Equinox::Migration::SimpleTagList;
   2
   3 # Copyright 2009-2012, Equinox Software, Inc.
   4 #
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9 #
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  18
  19 use warnings;
  20 use strict;
  21
  22 =head1 NAME
  23
  24 Equinox::Migration::SimpleTagList - Generate taglist from file
  25
  26 =head1 VERSION
  27
  28 Version 1.001
  29
  30 =cut
  31
  32 our $VERSION = '1.001';
  33
  34
  35 =head1 SYNOPSIS
  36
  37 Using a file as input, E::M::STL generates a set of MARC datafield
  38 tags and provides several access mechanisms to that set.
  39
  40     use Equinox::Migration::SimpleTagList;
  41
  42     my $stl = Equinox::Migration::SimpleTagList->new( file => "trashtags.txt" );
  43     my $tags = $stl->as_hashref;
  44
  45 or
  46
  47     my $stl = Equinox::Migration::SimpleTagList->new( file => "trashtags.txt" );
  48     if ( $stl->has($foo) ) {
  49         # if $foo is an element of $stl's parsed list
  50         # do stuff ...
  51     }
  52
  53
  54 =head1 ROUTINES
  55
  56
  57 =head2 new
  58
  59 Takes one optional argument, C<file>. If this is speficied, the tag
  60 list will be populated as per that file on instantiation.
  61
  62 Returns a E::M::STL object.
  63
  64 =cut
  65
  66 sub new {
  67     my ($class, %args) = @_;
  68
  69     my $self = bless { conf => { except => 0,
  70                                  range  => { high => 0, low => 0 },
  71                                  lastwasrange => 0,
  72                                },
  73                        tags => {} }, $class;
  74
  75     if ($args{file}) {
  76         if (-r $args{file}) {
  77             $self->generate($args{file});
  78         } else {
  79             die "Can't open tags file '", $args{file}, "': $!\n";
  80         }
  81     }elsif ($args{str}) {
  82         $self->generate($args{str},'scalar');
  83     }
  84
  85     return $self;
  86 }
  87
  88
  89
  90 =head2 has
  91
  92 Passed a data field tag, returns 1 if that tag is in the list and 0 if
  93 it is not.
  94
  95 When specifying tags under 100, they must be quoted if you wish to
  96 include the leading zeroes
  97
  98     $stl->has('011'); # is equivalent to
  99     $stl->has(11);
 100
 101 or Perl will think you're passing a (possibly malformed) octal value.
 102
 103 =cut
 104
 105 sub has { my ($self, $t) = @_; return 0 unless $t; $t =~ s/^0+//; return (defined $self->{tags}{$t}) ? 1 : 0 }
 106
 107 =head2 as_hashref
 108
 109 Returns a hashref of the entire, assembled tag list.
 110
 111 =cut
 112
 113 sub as_hashref { my ($self) = @_; return $self->{tags} }
 114
 115 =head2 as_hashref
 116
 117 Returns a listref of the entire, assembled tag list (sorted
 118 numerically by tag).
 119
 120 =cut
 121
 122 sub as_listref { my ($self) = @_; return [ sort {$a <=> $b} keys %{$self->{tags}} ] }
 123
 124 sub generate {
 125     my ($self, $file, $scalar) = @_;
 126
 127     if ($scalar) {
 128         open TAGFILE, '<', \$file;
 129     } else {
 130         open TAGFILE, '<', $file;
 131     }
 132     while (<TAGFILE>) {
 133         next if m/^#/;
 134         next if m/^\s*\n$/;
 135
 136         $self->{conf}{lastwasrange} = 0;
 137         $self->{conf}{range}{high}  = 0;
 138         $self->{conf}{range}{low}   = 0;
 139
 140         my @chunks = split /\s+/;
 141         while (my $chunk = shift @chunks) {
 142             last if ($chunk =~ /^#/);
 143
 144             # single values
 145             if ($chunk =~ /^\d{1,3}$/) {
 146                 $self->add_tag($chunk);
 147                 $self->{conf}{except} = 0;
 148                 next;
 149             }
 150
 151             # ranges
 152             if ($chunk =~ /^\d{1,3}\.\.\d{1,3}$/) {
 153                 $self->add_range($chunk);
 154                 $self->{conf}{except} = 0;
 155                 next;
 156             }
 157
 158             # 'except'
 159             if ($chunk eq 'except') {
 160                 die "Keyword 'except' can only follow a range (line $.)\n"
 161                   unless $self->{conf}{lastwasrange};
 162                 $self->{conf}{except} = 1;
 163                 next;
 164             }
 165
 166             die "Unknown chunk $chunk in tags file (line $.)\n";
 167         }
 168     }
 169 }
 170
 171 =head2 add_range
 172
 173 =cut
 174
 175 sub add_range {
 176     my ($self, $chunk) = @_;
 177     my ($low,$high) = split /\.\./, $chunk;
 178     $low =~ s/^0+//;
 179     $high =~ s/^0+//;
 180
 181     die "Ranges must be 'low..high' ($low is greater than $high)\n"
 182       if ($low > $high);
 183     if ($self->{conf}{except}) {
 184         die "Exception ranges must be within last addition range ($low..$high)\n"
 185           if ($low < $self->{conf}{range}{low} or $high > $self->{conf}{range}{high});
 186     }
 187     for my $tag ($low..$high) {
 188         $self->add_tag($tag)
 189     }
 190
 191     unless ($self->{conf}{except}) {
 192         $self->{conf}{range}{high} = $high;
 193         $self->{conf}{range}{low}  = $low;
 194     }
 195     $self->{conf}{lastwasrange} = 1;
 196 }
 197
 198 =head2 add_tag
 199
 200 =cut
 201
 202 sub add_tag {
 203     my ($self, $tag) = @_;
 204     $tag =~ s/^0+//;
 205
 206     die "Values must be numeric\n" if ($tag =~ /[^\d\-]/);
 207
 208     die "Values must be valid tags (0-999)\n"
 209       unless ($tag >= 0 and $tag <= 999);
 210
 211     if ($self->{conf}{except}) {
 212         $self->remove_tag($tag);
 213     } else {
 214         die "Tag '$tag' specified twice\n"
 215           if $self->{tags}{$tag};
 216         $self->{tags}{$tag} = 1;
 217         $self->{conf}{lastwasrange} = 0;
 218     }
 219 }
 220
 221 =head2 remove_tag
 222
 223 =cut
 224
 225 sub remove_tag {
 226     my ($self, $tag) = @_;
 227     $tag =~ s/^0+//;
 228
 229     die "Tag '$tag' isn't in the list\n"
 230       unless $self->{tags}{$tag};
 231     delete $self->{tags}{$tag};
 232 }
 233
 234 =head1 AUTHOR
 235
 236 Shawn Boyette, C<< <sboyette at esilibrary.com> >>
 237
 238 =head1 BUGS
 239
 240 Please report any bugs or feature requests to the above email address.
 241
 242 =head1 SUPPORT
 243
 244 You can find documentation for this module with the perldoc command.
 245
 246     perldoc Equinox::Migration::SimpleTagList
 247
 248
 249 =head1 COPYRIGHT & LICENSE
 250
 251 Copyright 2009 Equinox, all rights reserved.
 252
 253 This program is free software; you can redistribute it and/or modify it
 254 under the same terms as Perl itself.
 255
 256
 257 =cut
 258
 259 1; # End of Equinox::Migration::SimpleTagList