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