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.000
  13
  14 =cut
  15
  16 our $VERSION = '1.000';
  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 argument, optional argument, C<file>. If this is speficied,
  44 the tag 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->{conf}{file} = $args{file};
  62             $self->generate;
  63         } else {
  64             die "Can't open tags file: $!\n";
  65         }
  66     }
  67
  68     return $self;
  69 }
  70
  71
  72
  73 =head2 has
  74
  75 Passed a data field tag, returns 1 if that tag is in the list and 0 if
  76 it is not.
  77
  78 When specifying tags under 100, they must be quoted if you wish to
  79 include the leading zeroes
  80
  81     $stl->has('011'); # is equivalent to
  82     $stl->has(11);
  83
  84 or Perl will think you're passing a (possibly malformed) octal value.
  85
  86 =cut
  87
  88 sub has { my ($self, $t) = @_; $t =~ s/^0+//; return (defined $self->{tags}{$t}) ? 1 : 0 }
  89
  90 =head2 as_hashref
  91
  92 Returns a hashref of the entire, assembled tag list.
  93
  94 =cut
  95
  96 sub as_hashref { my ($self) = @_; return $self->{tags} }
  97
  98 =head2 as_hashref
  99
 100 Returns a listref of the entire, assembled tag list (sorted
 101 numerically by tag).
 102
 103 =cut
 104
 105 sub as_listref { my ($self) = @_; return [ sort {$a <=> $b} keys %{$self->{tags}} ] }
 106
 107 sub generate {
 108     my ($self) = @_;
 109
 110     open TAGFILE, '<', $self->{conf}{file};
 111     while (<TAGFILE>) {
 112         $self->{conf}{lastwasrange} = 0;
 113         $self->{conf}{range}{high}  = 0;
 114         $self->{conf}{range}{low}   = 0;
 115         $self->{conf}{except} = 0;
 116
 117         my @chunks = split /\s+/;
 118         while (my $chunk = shift @chunks) {
 119
 120             # single values
 121             if ($chunk =~ /^\d{1,3}$/) {
 122                 $self->add_tag($chunk);
 123                 next;
 124             }
 125
 126             # ranges
 127             if ($chunk =~ /^\d{1,3}\.\.\d{1,3}$/) {
 128                 $self->add_range($chunk);
 129                 next;
 130             }
 131
 132             # 'except'
 133             if ($chunk eq 'except') {
 134                 die "Keyword 'except' can only follow a range (line $.)\n"
 135                   unless $self->{conf}{lastwasrange};
 136                 die "Keyword 'except' may only occur once per line (line $.)\n"
 137                   if $self->{conf}{except};
 138                 $self->{conf}{except} = 1;
 139                 next;
 140             }
 141
 142             die "Unknown chunk $chunk in tags file (line $.)\n";
 143         }
 144     }
 145 }
 146
 147 =head2 add_range
 148
 149 =cut
 150
 151 sub add_range {
 152     my ($self, $chunk) = @_;
 153     my ($low,$high) = split /\.\./, $chunk;
 154     $low =~ s/^0+//;
 155     $high =~ s/^0+//;
 156
 157     die "Ranges must be 'low..high' ($low is greater than $high)\n"
 158       if ($low > $high);
 159     if ($self->{conf}{except}) {
 160         die "Exception ranges must be within last addition range ($low..$high)\n"
 161           if ($low < $self->{range}{low} or $high > $self->{range}{high});
 162     }
 163     for my $tag ($low..$high) {
 164         $self->add_tag($tag)
 165     }
 166
 167     unless ($self->{conf}{except}) {
 168         $self->{conf}{range}{high} = $high;
 169         $self->{conf}{range}{low}  = $low;
 170     }
 171     $self->{conf}{lastwasrange} = 1;
 172 }
 173
 174 =head2 add_tag
 175
 176 =cut
 177
 178 sub add_tag {
 179     my ($self, $tag) = @_;
 180     $tag =~ s/^0+//;
 181
 182     die "Values must be valid tags (0-999)\n"
 183       unless ($tag >= 0 and $tag <= 999);
 184
 185     if ($self->{conf}{except}) {
 186         $self->remove_tag($tag)
 187     } else {
 188         die "Tag '$tag' specified twice\n"
 189           if $self->{tags}{$tag};
 190         $self->{tags}{$tag} = 1;
 191     }
 192     $self->{conf}{lastwasrange} = 0;
 193 }
 194
 195 =head2 remove_tag
 196
 197 =cut
 198
 199 sub remove_tag {
 200     my ($self, $tag) = @_;
 201     $tag =~ s/^0+//;
 202
 203     die "Tag '$tag' isn't in the list\n"
 204       unless $self->{tags}{$tag};
 205     delete $self->{tags}{$tag};
 206 }
 207
 208 =head1 AUTHOR
 209
 210 Shawn Boyette, C<< <sboyette at esilibrary.com> >>
 211
 212 =head1 TODO
 213
 214 =over
 215
 216 =item * Remove single-except rule?
 217
 218 =back
 219
 220 =head1 BUGS
 221
 222 Please report any bugs or feature requests to the above email address.
 223
 224 =head1 SUPPORT
 225
 226 You can find documentation for this module with the perldoc command.
 227
 228     perldoc Equinox::Migration::TrashTags
 229
 230
 231 =head1 COPYRIGHT & LICENSE
 232
 233 Copyright 2009 Shawn Boyette, all rights reserved.
 234
 235 This program is free software; you can redistribute it and/or modify it
 236 under the same terms as Perl itself.
 237
 238
 239 =cut
 240
 241 1; # End of Equinox::Migration::SimpleTagList