lib/MHArc/Namazu.pm

   1 ##--------------------------------------------------------------------------##
   2 ##  File:
   3 ##      $Id: Namazu.pm,v 1.1 2002/09/03 16:30:47 ehood Exp $
   4 ##  Description:
   5 ##      POD at end of file.
   6 ##--------------------------------------------------------------------------##
   7 ##  Copyright (C) 2002  Earl Hood <earl@earlhood.com>
   8 ##
   9 ##  This program is free software; you can redistribute it and/or modify
  10 ##  it under the terms of the GNU General Public License as published by
  11 ##  the Free Software Foundation; either version 2 of the License, or
  12 ##  (at your option) any later version.
  13 ##
  14 ##  This program is distributed in the hope that it will be useful,
  15 ##  but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ##  GNU General Public License for more details.
  18 ##
  19 ##  You should have received a copy of the GNU General Public License
  20 ##  along with this program; if not, write to the Free Software
  21 ##  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  22 ##  02111-1307, USA
  23 ##--------------------------------------------------------------------------##
  24
  25 package MHArc::Namazu;
  26
  27 use Exporter;
  28 @ISA = qw(Exporter);
  29
  30 @EXPORT_OK = qw(
  31   &nmz_get_field
  32   &nmz_load_rc
  33   &nmz_msg_id_search
  34 );
  35
  36 use Fcntl;
  37
  38 ##--------------------------------------------------------------------------##
  39
  40 BEGIN {
  41   $Debug = 0;
  42 }
  43
  44 ##--------------------------------------------------------------------------##
  45
  46 sub nmz_msg_id_search {
  47   my $index_dir = shift;
  48   my $id        = shift;
  49
  50   # check format of message-id
  51   $id =~ s/\A\s+//;
  52   $id =~ s/\s+\Z//;
  53   if ($id !~ /\A<[^>]>\Z/) {
  54     $id = '<'.$id.'>';
  55   }
  56
  57   # Pathname to nmz field message-id file
  58   my $id_file = join('/', $index_dir, 'NMZ.field.message-id');
  59   if (! -e $id_file) {
  60     warn qq/"$id_file" does not exist\n/;
  61     return undef;
  62   }
  63
  64   local(*F);
  65   local($_);
  66   # see if message-id exists in archive
  67   if (!open(F, $id_file)) {
  68     warn qq/Unable to open "$id_file": $!\n/;
  69     return undef;
  70   }
  71   my $line = undef;
  72   while (<F>) {
  73     chomp;
  74     if (/^[^<]/) {
  75       # message-id in file not surrounded by <>'s
  76       $_ = '<'.$_.'>';
  77     }
  78     if ($id eq $_) {
  79       $line = $.;
  80       last;
  81     }
  82   }
  83   close(F);
  84
  85   $line;
  86 }
  87
  88 sub nmz_load_rc {
  89   my $file = shift;
  90
  91   local(*NMZRC);
  92   if (!open(NMZRC, $file)) {
  93     warn qq/Unable to open "$file": $!\n/;
  94     return undef;
  95   }
  96
  97   local $_;
  98   my $rc = { };
  99   my @index = ( );
 100   my $replace = ( );
 101   while (<NMZRC>) {
 102     next  if /^\s*#/;
 103     next  unless /\S/;
 104     chomp;
 105     my($opt, $value) = split(' ', $_, 2);
 106     $opt = lc $opt;
 107     if ($opt eq 'index') {
 108       $value =~ s/\s+\Z//;
 109       push(@index, $value);
 110       next;
 111     }
 112     if ($opt eq 'replace') {
 113       $value =~ s/\s+\Z//;
 114       push(@replace, [ split(' ', $value, 2) ]);
 115       next;
 116     }
 117   }
 118   $rc->{'index'} = [ @index ];
 119   $rc->{'replace'} = [ @replace ];
 120   $rc;
 121 }
 122
 123 sub nmz_get_field {
 124   my $index       = shift;    # Pathname of directory containing namazu index
 125   my $docid       = shift;    # Document ID (i.e. Line number)
 126   my $field       = lc shift; # Field to get value for
 127
 128   my $value        = undef;
 129   my $field_file   = join('/', $index, ('NMZ.field.'.$field));
 130   my $field_file_i = $field_file . '.i';
 131
 132   local(*F);
 133   if (!sysopen(F, $field_file_i, (O_RDONLY))) {
 134     warn qq/Unable to open "$field_file_i": $!\n/;
 135     return undef;
 136   }
 137   if (!defined(sysseek(F, (4*($docid-1)), SEEK_SET))) {
 138     warn qq/Unable to seek on "$field_file_i": $!\n/;
 139     close(F);
 140     return undef;
 141   }
 142   my $n = 4;
 143   my $bytes = '';
 144   while ($n > 0) {
 145     my $i = sysread(F, $bytes, $n, 4-$n);
 146     if (!defined($i)) {
 147       warn qq/sysread error for "$field_file_i": $!\n/;
 148       close(F);
 149       return undef;
 150     }
 151     if ($i == 0) {
 152       warn qq/Unexpected of EOF for "$field_file_i"\n/;
 153       close(F);
 154       return undef;
 155     }
 156     $n -= $i;
 157   }
 158   close(F);
 159
 160   my $offset = unpack('N', $bytes);
 161   if (!open(F, $field_file)) {
 162     warn qq/Unable to open "$field_file": $!\n/;
 163     return undef;
 164   }
 165   if (!seek(F, $offset, SEEK_SET)) {
 166     warn qq/Unable to seek to $offset on "$field_file": $!\n/;
 167     close(F);
 168     return undef;
 169   }
 170   $value = scalar(<F>);
 171   chomp $value  if defined($value);
 172   close(F);
 173
 174   $value;
 175 }
 176
 177 ##--------------------------------------------------------------------------##
 178 1;
 179 __END__
 180
 181 =head1 NAME
 182
 183 MHArc::Namazu - General Namazu-related utilities for mail archiving system.
 184
 185 =head1 SYNOPSIS
 186
 187   use MHArc::Namazu;
 188
 189 =head1 DESCRIPTION
 190
 191 This module contains a collection of Namazu-related utility routines.
 192
 193 =head1 VARIABLES
 194
 195 The following module variables can be set to affect the behavior
 196 of the utility routines:
 197
 198 =over
 199
 200 =item C<$Debug>
 201
 202 If set to a true value, routines will print out debugging information,
 203 if appropriate.
 204
 205 =back
 206
 207 =head1 ROUTINES
 208
 209 By default, no routines are exported into the calling namespace.
 210 Routines in this module can be imported by explicitly listing the
 211 routines to import in the C<use> declaration:
 212
 213   use MHArc::Namazu qw( nmz_get_field );
 214
 215 The following routines are availale:
 216
 217 =over
 218
 219 =item C<nmz_get_field($index, $docid, $field)>
 220
 221 Retrieve the value of a field for a document. C<$index> is the
 222 pathname of the directory containing Namazu index files.  C<$docid>
 223 is the ID of the document to retrieve a field value of.  Document
 224 ID correlate to the line numbers within C<NMZ.field.I<field-name>>
 225 files.  C<$field> is the field to retrieve the value of.
 226
 227 The return value of this function is the field value, or C<undef> if
 228 the field value could not determined.
 229
 230 Any error messages generated by this function are printed via Perl's
 231 C<warn> operator.
 232
 233 =item C<nmz_load_rc($filename)>
 234
 235 Parse Namazu configuration file denoted by C<$filename>.  The return
 236 value is a hash reference where the keys are the option names (normalized
 237 ot lowercases) and the values are the values associated with
 238 the options.  The actual value types depends on the option.
 239
 240 If the conf file cannot be loaded, C<undef> is returned.
 241
 242 =back
 243
 244 =head1 DEPENDENCIES
 245
 246 C<Fcntl>
 247
 248 =head1 VERSION
 249
 250 C<$Id: Namazu.pm,v 1.1 2002/09/03 16:30:47 ehood Exp $>
 251
 252 =head1 AUTHOR
 253
 254 Earl Hood, earl@earlhood.com
 255
 256 This module is part of the mharc archiving system and comes with
 257 ABSOLUTELY NO WARRANTY and may be copied only under the terms of
 258 the GNU General Public License, which may be found in the MHArc
 259 distribution.
 260
 261 =cut
 262