vcs.maemo.org Git - dh-make-perl/blob - dev/i386/libio-stringy-perl/io-stringy-2.110/lib/IO/InnerFile.pm

   1 package IO::InnerFile;
   2
   3 =head1 NAME
   4
   5 IO::InnerFile - define a file inside another file
   6
   7
   8 =head1 SYNOPSIS
   9
  10
  11     ### Read a subset of a file:
  12     $inner = IO::InnerFile->new($fh, $start, $length);
  13     while (<$inner>) {
  14         ...
  15     }
  16
  17
  18 =head1 DESCRIPTION
  19
  20 If you have a filehandle that can seek() and tell(), then you
  21 can open an IO::InnerFile on a range of the underlying file.
  22
  23
  24 =head1 PUBLIC INTERFACE
  25
  26 =over
  27
  28 =cut
  29
  30 use Symbol;
  31
  32 # The package version, both in 1.23 style *and* usable by MakeMaker:
  33 $VERSION = "2.110";
  34
  35 #------------------------------
  36
  37 =item new FILEHANDLE, [START, [LENGTH]]
  38
  39 I<Class method, constructor.>
  40 Create a new inner-file opened on the given FILEHANDLE,
  41 from bytes START to START+LENGTH.  Both START and LENGTH
  42 default to 0; negative values are silently coerced to zero.
  43
  44 Note that FILEHANDLE must be able to seek() and tell(), in addition
  45 to whatever other methods you may desire for reading it.
  46
  47 =cut
  48
  49 sub new {
  50    my ($class, $fh, $start, $lg) = @_;
  51    $start = 0 if (!$start or ($start < 0));
  52    $lg    = 0 if (!$lg    or ($lg    < 0));
  53
  54    ### Create the underlying "object":
  55    my $a = {
  56       FH        =>      $fh,
  57       CRPOS     =>      0,
  58       START     =>      $start,
  59       LG        =>      $lg,
  60    };
  61
  62    ### Create a new filehandle tied to this object:
  63    $fh = gensym;
  64    tie(*$fh, $class, $a);
  65    return bless($fh, $class);
  66 }
  67
  68 sub TIEHANDLE {
  69    my ($class, $data) = @_;
  70    return bless($data, $class);
  71 }
  72
  73 sub DESTROY {
  74    my ($self) = @_;
  75    $self->close() if (ref($self) eq 'SCALAR');
  76 }
  77
  78 #------------------------------
  79
  80 =item set_length LENGTH
  81
  82 =item get_length
  83
  84 =item add_length NBYTES
  85
  86 I<Instance methods.>
  87 Get/set the virtual length of the inner file.
  88
  89 =cut
  90
  91 sub set_length { tied(${$_[0]})->{LG} = $_[1]; }
  92 sub get_length { tied(${$_[0]})->{LG}; }
  93 sub add_length { tied(${$_[0]})->{LG} += $_[1]; }
  94
  95 #------------------------------
  96
  97 =item set_start START
  98
  99 =item get_start
 100
 101 =item add_start NBYTES
 102
 103 I<Instance methods.>
 104 Get/set the virtual start position of the inner file.
 105
 106 =cut
 107
 108 sub set_start  { tied(${$_[0]})->{START} = $_[1]; }
 109 sub get_start  { tied(${$_[0]})->{START}; }
 110 sub set_end    { tied(${$_[0]})->{LG} =  $_[1] - tied(${$_[0]})->{START}; }
 111 sub get_end    { tied(${$_[0]})->{LG} + tied(${$_[0]})->{START}; }
 112
 113
 114 #------------------------------
 115
 116 =item binmode
 117
 118 =item close
 119
 120 =item flush
 121
 122 =item getc
 123
 124 =item getline
 125
 126 =item print LIST
 127
 128 =item printf LIST
 129
 130 =item read BUF, NBYTES
 131
 132 =item readline
 133
 134 =item seek OFFFSET, WHENCE
 135
 136 =item tell
 137
 138 =item write ARGS...
 139
 140 I<Instance methods.>
 141 Standard filehandle methods.
 142
 143 =cut
 144
 145 sub write    { shift->WRITE(@_) }
 146 sub print    { shift->PRINT(@_) }
 147 sub printf   { shift->PRINTF(@_) }
 148 sub flush    { "0 but true"; }
 149 sub binmode  { 1; }
 150 sub getc     { return GETC(tied(${$_[0]}) ); }
 151 sub read     { return READ(     tied(${$_[0]}), @_[1,2,3] ); }
 152 sub readline { return READLINE( tied(${$_[0]}) ); }
 153 sub getline  { return READLINE( tied(${$_[0]}) ); }
 154 sub close    { return CLOSE(tied(${$_[0]}) ); }
 155
 156 sub seek {
 157    my ($self, $ofs, $whence) = @_;
 158    $self = tied( $$self );
 159
 160    $self->{CRPOS} = $ofs if ($whence == 0);
 161    $self->{CRPOS}+= $ofs if ($whence == 1);
 162    $self->{CRPOS} = $self->{LG} + $ofs if ($whence == 2);
 163
 164    $self->{CRPOS} = 0 if ($self->{CRPOS} < 0);
 165    $self->{CRPOS} = $self->{LG} if ($self->{CRPOS} > $self->{LG});
 166    return 1;
 167 }
 168
 169 sub tell {
 170     return tied(${$_[0]})->{CRPOS};
 171 }
 172
 173 sub WRITE  {
 174     die "inner files can only open for reading\n";
 175 }
 176
 177 sub PRINT  {
 178     die "inner files can only open for reading\n";
 179 }
 180
 181 sub PRINTF {
 182     die "inner files can only open for reading\n";
 183 }
 184
 185 sub GETC   {
 186     my ($self) = @_;
 187     return 0 if ($self->{CRPOS} >= $self->{LG});
 188
 189     my $data;
 190
 191     ### Save and seek...
 192     my $old_pos = $self->{FH}->tell;
 193     $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
 194
 195     ### ...read...
 196     my $lg = $self->{FH}->read($data, 1);
 197     $self->{CRPOS} += $lg;
 198
 199     ### ...and restore:
 200     $self->{FH}->seek($old_pos, 0);
 201
 202     $self->{LG} = $self->{CRPOS} unless ($lg);
 203     return ($lg ? $data : undef);
 204 }
 205
 206 sub READ   {
 207     my ($self, $undefined, $lg, $ofs) = @_;
 208     $undefined = undef;
 209
 210     return 0 if ($self->{CRPOS} >= $self->{LG});
 211     $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
 212     return 0 unless ($lg);
 213
 214     ### Save and seek...
 215     my $old_pos = $self->{FH}->tell;
 216     $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
 217
 218     ### ...read...
 219     $lg = $self->{FH}->read($_[1], $lg, $_[3] );
 220     $self->{CRPOS} += $lg;
 221
 222     ### ...and restore:
 223     $self->{FH}->seek($old_pos, 0);
 224
 225     $self->{LG} = $self->{CRPOS} unless ($lg);
 226     return $lg;
 227 }
 228
 229 sub READLINE {
 230     my ($self) = @_;
 231     return undef if ($self->{CRPOS} >= $self->{LG});
 232
 233     ### Save and seek...
 234     my $old_pos = $self->{FH}->tell;
 235     $self->{FH}->seek($self->{CRPOS}+$self->{START}, 0);
 236
 237     ### ...read...
 238     my $text = $self->{FH}->getline;
 239
 240     ### ...and restore:
 241     $self->{FH}->seek($old_pos, 0);
 242
 243     #### If we detected a new EOF ...
 244     unless (defined $text) {
 245        $self->{LG} = $self->{CRPOS};
 246        return undef;
 247     }
 248
 249     my $lg=length($text);
 250
 251     $lg = $self->{LG} - $self->{CRPOS} if ($self->{CRPOS} + $lg > $self->{LG});
 252     $self->{CRPOS} += $lg;
 253
 254     return substr($text, 0,$lg);
 255 }
 256
 257 sub CLOSE { %{$_[0]}=(); }
 258
 259
 260
 261 1;
 262 __END__
 263
 264 =back
 265
 266
 267 =head1 VERSION
 268
 269 $Id: InnerFile.pm,v 1.4 2005/02/10 21:21:53 dfs Exp $
 270
 271
 272 =head1 AUTHOR
 273
 274 Original version by Doru Petrescu (pdoru@kappa.ro).
 275
 276 Documentation and by Eryq (eryq@zeegee.com).
 277
 278 Currently maintained by David F. Skoll (dfs@roaringpenguin.com).
 279
 280 =cut
 281
 282