Commit | Line | Data |
3fea05b9 |
1 | package IO::String; |
2 | |
3 | # Copyright 1998-2005 Gisle Aas. |
4 | # |
5 | # This library is free software; you can redistribute it and/or |
6 | # modify it under the same terms as Perl itself. |
7 | |
8 | require 5.005_03; |
9 | use strict; |
10 | use vars qw($VERSION $DEBUG $IO_CONSTANTS); |
11 | $VERSION = "1.08"; # $Date: 2005/12/05 12:00:47 $ |
12 | |
13 | use Symbol (); |
14 | |
15 | sub new |
16 | { |
17 | my $class = shift; |
18 | my $self = bless Symbol::gensym(), ref($class) || $class; |
19 | tie *$self, $self; |
20 | $self->open(@_); |
21 | return $self; |
22 | } |
23 | |
24 | sub open |
25 | { |
26 | my $self = shift; |
27 | return $self->new(@_) unless ref($self); |
28 | |
29 | if (@_) { |
30 | my $bufref = ref($_[0]) ? $_[0] : \$_[0]; |
31 | $$bufref = "" unless defined $$bufref; |
32 | *$self->{buf} = $bufref; |
33 | } |
34 | else { |
35 | my $buf = ""; |
36 | *$self->{buf} = \$buf; |
37 | } |
38 | *$self->{pos} = 0; |
39 | *$self->{lno} = 0; |
40 | return $self; |
41 | } |
42 | |
43 | sub pad |
44 | { |
45 | my $self = shift; |
46 | my $old = *$self->{pad}; |
47 | *$self->{pad} = substr($_[0], 0, 1) if @_; |
48 | return "\0" unless defined($old) && length($old); |
49 | return $old; |
50 | } |
51 | |
52 | sub dump |
53 | { |
54 | require Data::Dumper; |
55 | my $self = shift; |
56 | print Data::Dumper->Dump([$self], ['*self']); |
57 | print Data::Dumper->Dump([*$self{HASH}], ['$self{HASH}']); |
58 | return; |
59 | } |
60 | |
61 | sub TIEHANDLE |
62 | { |
63 | print "TIEHANDLE @_\n" if $DEBUG; |
64 | return $_[0] if ref($_[0]); |
65 | my $class = shift; |
66 | my $self = bless Symbol::gensym(), $class; |
67 | $self->open(@_); |
68 | return $self; |
69 | } |
70 | |
71 | sub DESTROY |
72 | { |
73 | print "DESTROY @_\n" if $DEBUG; |
74 | } |
75 | |
76 | sub close |
77 | { |
78 | my $self = shift; |
79 | delete *$self->{buf}; |
80 | delete *$self->{pos}; |
81 | delete *$self->{lno}; |
82 | undef *$self if $] eq "5.008"; # workaround for some bug |
83 | return 1; |
84 | } |
85 | |
86 | sub opened |
87 | { |
88 | my $self = shift; |
89 | return defined *$self->{buf}; |
90 | } |
91 | |
92 | sub binmode |
93 | { |
94 | my $self = shift; |
95 | return 1 unless @_; |
96 | # XXX don't know much about layers yet :-( |
97 | return 0; |
98 | } |
99 | |
100 | sub getc |
101 | { |
102 | my $self = shift; |
103 | my $buf; |
104 | return $buf if $self->read($buf, 1); |
105 | return undef; |
106 | } |
107 | |
108 | sub ungetc |
109 | { |
110 | my $self = shift; |
111 | $self->setpos($self->getpos() - 1); |
112 | return 1; |
113 | } |
114 | |
115 | sub eof |
116 | { |
117 | my $self = shift; |
118 | return length(${*$self->{buf}}) <= *$self->{pos}; |
119 | } |
120 | |
121 | sub print |
122 | { |
123 | my $self = shift; |
124 | if (defined $\) { |
125 | if (defined $,) { |
126 | $self->write(join($,, @_).$\); |
127 | } |
128 | else { |
129 | $self->write(join("",@_).$\); |
130 | } |
131 | } |
132 | else { |
133 | if (defined $,) { |
134 | $self->write(join($,, @_)); |
135 | } |
136 | else { |
137 | $self->write(join("",@_)); |
138 | } |
139 | } |
140 | return 1; |
141 | } |
142 | *printflush = \*print; |
143 | |
144 | sub printf |
145 | { |
146 | my $self = shift; |
147 | print "PRINTF(@_)\n" if $DEBUG; |
148 | my $fmt = shift; |
149 | $self->write(sprintf($fmt, @_)); |
150 | return 1; |
151 | } |
152 | |
153 | |
154 | my($SEEK_SET, $SEEK_CUR, $SEEK_END); |
155 | |
156 | sub _init_seek_constants |
157 | { |
158 | if ($IO_CONSTANTS) { |
159 | require IO::Handle; |
160 | $SEEK_SET = &IO::Handle::SEEK_SET; |
161 | $SEEK_CUR = &IO::Handle::SEEK_CUR; |
162 | $SEEK_END = &IO::Handle::SEEK_END; |
163 | } |
164 | else { |
165 | $SEEK_SET = 0; |
166 | $SEEK_CUR = 1; |
167 | $SEEK_END = 2; |
168 | } |
169 | } |
170 | |
171 | |
172 | sub seek |
173 | { |
174 | my($self,$off,$whence) = @_; |
175 | my $buf = *$self->{buf} || return 0; |
176 | my $len = length($$buf); |
177 | my $pos = *$self->{pos}; |
178 | |
179 | _init_seek_constants() unless defined $SEEK_SET; |
180 | |
181 | if ($whence == $SEEK_SET) { $pos = $off } |
182 | elsif ($whence == $SEEK_CUR) { $pos += $off } |
183 | elsif ($whence == $SEEK_END) { $pos = $len + $off } |
184 | else { die "Bad whence ($whence)" } |
185 | print "SEEK(POS=$pos,OFF=$off,LEN=$len)\n" if $DEBUG; |
186 | |
187 | $pos = 0 if $pos < 0; |
188 | $self->truncate($pos) if $pos > $len; # extend file |
189 | *$self->{pos} = $pos; |
190 | return 1; |
191 | } |
192 | |
193 | sub pos |
194 | { |
195 | my $self = shift; |
196 | my $old = *$self->{pos}; |
197 | if (@_) { |
198 | my $pos = shift || 0; |
199 | my $buf = *$self->{buf}; |
200 | my $len = $buf ? length($$buf) : 0; |
201 | $pos = $len if $pos > $len; |
202 | *$self->{pos} = $pos; |
203 | } |
204 | return $old; |
205 | } |
206 | |
207 | sub getpos { shift->pos; } |
208 | |
209 | *sysseek = \&seek; |
210 | *setpos = \&pos; |
211 | *tell = \&getpos; |
212 | |
213 | |
214 | |
215 | sub getline |
216 | { |
217 | my $self = shift; |
218 | my $buf = *$self->{buf} || return; |
219 | my $len = length($$buf); |
220 | my $pos = *$self->{pos}; |
221 | return if $pos >= $len; |
222 | |
223 | unless (defined $/) { # slurp |
224 | *$self->{pos} = $len; |
225 | return substr($$buf, $pos); |
226 | } |
227 | |
228 | unless (length $/) { # paragraph mode |
229 | # XXX slow&lazy implementation using getc() |
230 | my $para = ""; |
231 | my $eol = 0; |
232 | my $c; |
233 | while (defined($c = $self->getc)) { |
234 | if ($c eq "\n") { |
235 | $eol++; |
236 | next if $eol > 2; |
237 | } |
238 | elsif ($eol > 1) { |
239 | $self->ungetc($c); |
240 | last; |
241 | } |
242 | else { |
243 | $eol = 0; |
244 | } |
245 | $para .= $c; |
246 | } |
247 | return $para; # XXX wantarray |
248 | } |
249 | |
250 | my $idx = index($$buf,$/,$pos); |
251 | if ($idx < 0) { |
252 | # return rest of it |
253 | *$self->{pos} = $len; |
254 | $. = ++ *$self->{lno}; |
255 | return substr($$buf, $pos); |
256 | } |
257 | $len = $idx - $pos + length($/); |
258 | *$self->{pos} += $len; |
259 | $. = ++ *$self->{lno}; |
260 | return substr($$buf, $pos, $len); |
261 | } |
262 | |
263 | sub getlines |
264 | { |
265 | die "getlines() called in scalar context\n" unless wantarray; |
266 | my $self = shift; |
267 | my($line, @lines); |
268 | push(@lines, $line) while defined($line = $self->getline); |
269 | return @lines; |
270 | } |
271 | |
272 | sub READLINE |
273 | { |
274 | goto &getlines if wantarray; |
275 | goto &getline; |
276 | } |
277 | |
278 | sub input_line_number |
279 | { |
280 | my $self = shift; |
281 | my $old = *$self->{lno}; |
282 | *$self->{lno} = shift if @_; |
283 | return $old; |
284 | } |
285 | |
286 | sub truncate |
287 | { |
288 | my $self = shift; |
289 | my $len = shift || 0; |
290 | my $buf = *$self->{buf}; |
291 | if (length($$buf) >= $len) { |
292 | substr($$buf, $len) = ''; |
293 | *$self->{pos} = $len if $len < *$self->{pos}; |
294 | } |
295 | else { |
296 | $$buf .= ($self->pad x ($len - length($$buf))); |
297 | } |
298 | return 1; |
299 | } |
300 | |
301 | sub read |
302 | { |
303 | my $self = shift; |
304 | my $buf = *$self->{buf}; |
305 | return undef unless $buf; |
306 | |
307 | my $pos = *$self->{pos}; |
308 | my $rem = length($$buf) - $pos; |
309 | my $len = $_[1]; |
310 | $len = $rem if $len > $rem; |
311 | return undef if $len < 0; |
312 | if (@_ > 2) { # read offset |
313 | substr($_[0],$_[2]) = substr($$buf, $pos, $len); |
314 | } |
315 | else { |
316 | $_[0] = substr($$buf, $pos, $len); |
317 | } |
318 | *$self->{pos} += $len; |
319 | return $len; |
320 | } |
321 | |
322 | sub write |
323 | { |
324 | my $self = shift; |
325 | my $buf = *$self->{buf}; |
326 | return unless $buf; |
327 | |
328 | my $pos = *$self->{pos}; |
329 | my $slen = length($_[0]); |
330 | my $len = $slen; |
331 | my $off = 0; |
332 | if (@_ > 1) { |
333 | $len = $_[1] if $_[1] < $len; |
334 | if (@_ > 2) { |
335 | $off = $_[2] || 0; |
336 | die "Offset outside string" if $off > $slen; |
337 | if ($off < 0) { |
338 | $off += $slen; |
339 | die "Offset outside string" if $off < 0; |
340 | } |
341 | my $rem = $slen - $off; |
342 | $len = $rem if $rem < $len; |
343 | } |
344 | } |
345 | substr($$buf, $pos, $len) = substr($_[0], $off, $len); |
346 | *$self->{pos} += $len; |
347 | return $len; |
348 | } |
349 | |
350 | *sysread = \&read; |
351 | *syswrite = \&write; |
352 | |
353 | sub stat |
354 | { |
355 | my $self = shift; |
356 | return unless $self->opened; |
357 | return 1 unless wantarray; |
358 | my $len = length ${*$self->{buf}}; |
359 | |
360 | return ( |
361 | undef, undef, # dev, ino |
362 | 0666, # filemode |
363 | 1, # links |
364 | $>, # user id |
365 | $), # group id |
366 | undef, # device id |
367 | $len, # size |
368 | undef, # atime |
369 | undef, # mtime |
370 | undef, # ctime |
371 | 512, # blksize |
372 | int(($len+511)/512) # blocks |
373 | ); |
374 | } |
375 | |
376 | sub FILENO { |
377 | return undef; # XXX perlfunc says this means the file is closed |
378 | } |
379 | |
380 | sub blocking { |
381 | my $self = shift; |
382 | my $old = *$self->{blocking} || 0; |
383 | *$self->{blocking} = shift if @_; |
384 | return $old; |
385 | } |
386 | |
387 | my $notmuch = sub { return }; |
388 | |
389 | *fileno = $notmuch; |
390 | *error = $notmuch; |
391 | *clearerr = $notmuch; |
392 | *sync = $notmuch; |
393 | *flush = $notmuch; |
394 | *setbuf = $notmuch; |
395 | *setvbuf = $notmuch; |
396 | |
397 | *untaint = $notmuch; |
398 | *autoflush = $notmuch; |
399 | *fcntl = $notmuch; |
400 | *ioctl = $notmuch; |
401 | |
402 | *GETC = \&getc; |
403 | *PRINT = \&print; |
404 | *PRINTF = \&printf; |
405 | *READ = \&read; |
406 | *WRITE = \&write; |
407 | *SEEK = \&seek; |
408 | *TELL = \&getpos; |
409 | *EOF = \&eof; |
410 | *CLOSE = \&close; |
411 | *BINMODE = \&binmode; |
412 | |
413 | |
414 | sub string_ref |
415 | { |
416 | my $self = shift; |
417 | return *$self->{buf}; |
418 | } |
419 | *sref = \&string_ref; |
420 | |
421 | 1; |
422 | |
423 | __END__ |
424 | |
425 | =head1 NAME |
426 | |
427 | IO::String - Emulate file interface for in-core strings |
428 | |
429 | =head1 SYNOPSIS |
430 | |
431 | use IO::String; |
432 | $io = IO::String->new; |
433 | $io = IO::String->new($var); |
434 | tie *IO, 'IO::String'; |
435 | |
436 | # read data |
437 | <$io>; |
438 | $io->getline; |
439 | read($io, $buf, 100); |
440 | |
441 | # write data |
442 | print $io "string\n"; |
443 | $io->print(@data); |
444 | syswrite($io, $buf, 100); |
445 | |
446 | select $io; |
447 | printf "Some text %s\n", $str; |
448 | |
449 | # seek |
450 | $pos = $io->getpos; |
451 | $io->setpos(0); # rewind |
452 | $io->seek(-30, -1); |
453 | seek($io, 0, 0); |
454 | |
455 | =head1 DESCRIPTION |
456 | |
457 | The C<IO::String> module provides the C<IO::File> interface for in-core |
458 | strings. An C<IO::String> object can be attached to a string, and |
459 | makes it possible to use the normal file operations for reading or |
460 | writing data, as well as for seeking to various locations of the string. |
461 | This is useful when you want to use a library module that only |
462 | provides an interface to file handles on data that you have in a string |
463 | variable. |
464 | |
465 | Note that perl-5.8 and better has built-in support for "in memory" |
466 | files, which are set up by passing a reference instead of a filename |
467 | to the open() call. The reason for using this module is that it |
468 | makes the code backwards compatible with older versions of Perl. |
469 | |
470 | The C<IO::String> module provides an interface compatible with |
471 | C<IO::File> as distributed with F<IO-1.20>, but the following methods |
472 | are not available: new_from_fd, fdopen, format_write, |
473 | format_page_number, format_lines_per_page, format_lines_left, |
474 | format_name, format_top_name. |
475 | |
476 | The following methods are specific to the C<IO::String> class: |
477 | |
478 | =over 4 |
479 | |
480 | =item $io = IO::String->new |
481 | |
482 | =item $io = IO::String->new( $string ) |
483 | |
484 | The constructor returns a newly-created C<IO::String> object. It |
485 | takes an optional argument, which is the string to read from or write |
486 | into. If no $string argument is given, then an internal buffer |
487 | (initially empty) is allocated. |
488 | |
489 | The C<IO::String> object returned is tied to itself. This means |
490 | that you can use most Perl I/O built-ins on it too: readline, <>, getc, |
491 | print, printf, syswrite, sysread, close. |
492 | |
493 | =item $io->open |
494 | |
495 | =item $io->open( $string ) |
496 | |
497 | Attaches an existing IO::String object to some other $string, or |
498 | allocates a new internal buffer (if no argument is given). The |
499 | position is reset to 0. |
500 | |
501 | =item $io->string_ref |
502 | |
503 | Returns a reference to the string that is attached to |
504 | the C<IO::String> object. Most useful when you let the C<IO::String> |
505 | create an internal buffer to write into. |
506 | |
507 | =item $io->pad |
508 | |
509 | =item $io->pad( $char ) |
510 | |
511 | Specifies the padding to use if |
512 | the string is extended by either the seek() or truncate() methods. It |
513 | is a single character and defaults to "\0". |
514 | |
515 | =item $io->pos |
516 | |
517 | =item $io->pos( $newpos ) |
518 | |
519 | Yet another interface for reading and setting the current read/write |
520 | position within the string (the normal getpos/setpos/tell/seek |
521 | methods are also available). The pos() method always returns the |
522 | old position, and if you pass it an argument it sets the new |
523 | position. |
524 | |
525 | There is (deliberately) a difference between the setpos() and seek() |
526 | methods in that seek() extends the string (with the specified |
527 | padding) if you go to a location past the end, whereas setpos() |
528 | just snaps back to the end. If truncate() is used to extend the string, |
529 | then it works as seek(). |
530 | |
531 | =back |
532 | |
533 | =head1 BUGS |
534 | |
535 | In Perl versions < 5.6, the TIEHANDLE interface was incomplete. |
536 | If you use such a Perl, then seek(), tell(), eof(), fileno(), binmode() will |
537 | not do anything on an C<IO::String> handle. See L<perltie> for |
538 | details. |
539 | |
540 | =head1 SEE ALSO |
541 | |
542 | L<IO::File>, L<IO::Stringy>, L<perlfunc/open> |
543 | |
544 | =head1 COPYRIGHT |
545 | |
546 | Copyright 1998-2005 Gisle Aas. |
547 | |
548 | This library is free software; you can redistribute it and/or |
549 | modify it under the same terms as Perl itself. |
550 | |
551 | =cut |