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 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->{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
 116         my @chunks = split /\s+/;
 117         while (my $chunk = shift @chunks) {
 118
 119             # single values
 120             if ($chunk =~ /^\d{1,3}$/) {
 121                 $self->add_tag($chunk);
 122                 $self->{conf}{except} = 0;
 123                 next;
 124             }
 125
 126             # ranges
 127             if ($chunk =~ /^\d{1,3}\.\.\d{1,3}$/) {
 128                 $self->add_range($chunk);
 129                 $self->{conf}{except} = 0;
 130                 next;
 131             }
 132
 133             # 'except'
 134             if ($chunk eq 'except') {
 135                 die "Keyword 'except' can only follow a range (line $.)\n"
 136                   unless $self->{conf}{lastwasrange};
 137                 $self->{conf}{except} = 1;
 138                 next;
 139             }
 140
 141             die "Unknown chunk $chunk in tags file (line $.)\n";
 142         }
 143     }
 144 }
 145
 146 =head2 add_range
 147
 148 =cut
 149
 150 sub add_range {
 151     my ($self, $chunk) = @_;
 152     my ($low,$high) = split /\.\./, $chunk;
 153     $low =~ s/^0+//;
 154     $high =~ s/^0+//;
 155
 156     die "Ranges must be 'low..high' ($low is greater than $high)\n"
 157       if ($low > $high);
 158     if ($self->{conf}{except}) {
 159         die "Exception ranges must be within last addition range ($low..$high)\n"
 160           if ($low < $self->{conf}{range}{low} or $high > $self->{conf}{range}{high});
 161     }
 162     for my $tag ($low..$high) {
 163         $self->add_tag($tag)
 164     }
 165
 166     unless ($self->{conf}{except}) {
 167         $self->{conf}{range}{high} = $high;
 168         $self->{conf}{range}{low}  = $low;
 169     }
 170     $self->{conf}{lastwasrange} = 1;
 171 }
 172
 173 =head2 add_tag
 174
 175 =cut
 176
 177 sub add_tag {
 178     my ($self, $tag) = @_;
 179     $tag =~ s/^0+//;
 180
 181     die "Values must be numeric\n" if ($tag =~ /[^\d\-]/);
 182
 183     die "Values must be valid tags (0-999)\n"
 184       unless ($tag >= 0 and $tag <= 999);
 185
 186     if ($self->{conf}{except}) {
 187         $self->remove_tag($tag);
 188     } else {
 189         die "Tag '$tag' specified twice\n"
 190           if $self->{tags}{$tag};
 191         $self->{tags}{$tag} = 1;
 192         $self->{conf}{lastwasrange} = 0;
 193     }
 194 }
 195
 196 =head2 remove_tag
 197
 198 =cut
 199
 200 sub remove_tag {
 201     my ($self, $tag) = @_;
 202     $tag =~ s/^0+//;
 203
 204     die "Tag '$tag' isn't in the list\n"
 205       unless $self->{tags}{$tag};
 206     delete $self->{tags}{$tag};
 207 }
 208
 209 =head1 AUTHOR
 210
 211 Shawn Boyette, C<< <sboyette at esilibrary.com> >>
 212
 213 =head1 BUGS
 214
 215 Please report any bugs or feature requests to the above email address.
 216
 217 =head1 SUPPORT
 218
 219 You can find documentation for this module with the perldoc command.
 220
 221     perldoc Equinox::Migration::SimpleTagList
 222
 223
 224 =head1 COPYRIGHT & LICENSE
 225
 226 Copyright 2009 Equinox, all rights reserved.
 227
 228 This program is free software; you can redistribute it and/or modify it
 229 under the same terms as Perl itself.
 230
 231
 232 =cut
 233
 234 1; # End of Equinox::Migration::SimpleTagList