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

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