[p5sagit/p5-mst-13.2.git] / ext / FileHandle / FileHandle.pm

package FileHandle;

=head1 NAME

FileHandle - supply object methods for filehandles

=head1 SYNOPSIS

    use FileHandle;

    $fh = new FileHandle;
    if ($fh->open "< file") {
        print <$fh>;
        $fh->close;
    }

    $fh = new FileHandle "> FOO";
    if (defined $fh) {
        print $fh "bar\n";
        $fh->close;
    }

    $fh = new FileHandle "file", "r";
    if (defined $fh) {
        print <$fh>;
        undef $fh;       # automatically closes the file
    }

    $fh = new FileHandle "file", O_WRONLY|O_APPEND;
    if (defined $fh) {
        print $fh "corge\n";
        undef $fh;       # automatically closes the file
    }

    ($readfh, $writefh) = FileHandle::pipe;

    autoflush STDOUT 1;
  
=head1 DESCRIPTION

C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
newly created symbol (see the C<Symbol> package).  If it receives any
parameters, they are passed to C<FileHandle::open>; if the open fails,
the C<FileHandle> object is destroyed.  Otherwise, it is returned to
the caller.

C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
It requires two parameters, which are passed to C<FileHandle::fdopen>;
if the fdopen fails, the C<FileHandle> object is destroyed.
Otherwise, it is returned to the caller.

C<FileHandle::open> accepts one parameter or two.  With one parameter,
it is just a front end for the built-in C<open> function.  With two
parameters, the first parameter is a filename that may include
whitespace or other special characters, and the second parameter is
the open mode in either Perl form (">", "+<", etc.) or POSIX form
("w", "r+", etc.).

C<FileHandle::fdopen> is like C<open> except that its first parameter
is not a filename but rather a file handle name, a FileHandle object,
or a file descriptor number.

See L<perlfunc> for complete descriptions of each of the following
supported C<FileHandle> methods, which are just front ends for the
corresponding built-in functions:
  
    close
    fileno
    getc
    gets
    eof
    clearerr
    seek
    tell

See L<perlvar> for complete descriptions of each of the following
supported C<FileHandle> methods:

    autoflush
    output_field_separator
    output_record_separator
    input_record_separator
    input_line_number
    format_page_number
    format_lines_per_page
    format_lines_left
    format_name
    format_top_name
    format_line_break_characters
    format_formfeed

Furthermore, for doing normal I/O you might need these:

=over 

=item $fh->print

See L<perlfunc/print>.

=item $fh->printf

See L<perlfunc/printf>.

=item $fh->getline

This works like <$fh> described in L<perlop/"I/O Operators">
except that it's more readable and can be safely called in an
array context but still returns just one line.

=item $fh->getlines

This works like <$fh> when called in an array context to
read all the remaining lines in a file, except that it's more readable.
It will also croak() if accidentally called in a scalar context.

=back

=head1 SEE ALSO

L<perlfunc>, 
L<perlop/"I/O Operators">,
L<POSIX/"FileHandle">

=head1 BUGS

Due to backwards compatibility, all filehandles resemble objects
of class C<FileHandle>, or actually classes derived from that class.
They actually aren't.  Which means you can't derive your own 
class from C<FileHandle> and inherit those methods.

=cut

require 5.000;
use Carp;
use Fcntl;
use Symbol;
use English;
use SelectSaver;

require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);

@EXPORT = (@Fcntl::EXPORT,
	   qw(_IOFBF _IOLBF _IONBF));

@EXPORT_OK = qw(
    autoflush
    output_field_separator
    output_record_separator
    input_record_separator
    input_line_number
    format_page_number
    format_lines_per_page
    format_lines_left
    format_name
    format_top_name
    format_line_break_characters
    format_formfeed

    print
    printf
    getline
    getlines
);


################################################
## Interaction with the XS.
##

bootstrap FileHandle;

sub AUTOLOAD {
    if ($AUTOLOAD =~ /::(_?[a-z])/) {
	$AutoLoader::AUTOLOAD = $AUTOLOAD;
	goto &AutoLoader::AUTOLOAD
    }
    my $constname = $AUTOLOAD;
    $constname =~ s/.*:://;
    my $val = constant($constname);
    defined $val or croak "$constname is not a valid FileHandle macro";
    *$AUTOLOAD = sub { $val };
    goto &$AUTOLOAD;
}


################################################
## Constructors, destructors.
##

sub new {
    @_ >= 1 && @_ <= 3 or croak 'usage: new FileHandle [FILENAME [,MODE]]';
    my $class = shift;
    my $fh = gensym;
    if (@_) {
	FileHandle::open($fh, @_)
	    or return undef;
    }
    bless $fh, $class;
}

sub new_from_fd {
    @_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE';
    my $class = shift;
    my $fh = gensym;
    FileHandle::fdopen($fh, @_)
	or return undef;
    bless $fh, $class;
}

sub DESTROY {
    my ($fh) = @_;
    close($fh);
}

################################################
## Open and close.
##

sub pipe {
    @_ and croak 'usage: FileHandle::pipe()';
    my $readfh = new FileHandle;
    my $writefh = new FileHandle;
    pipe($readfh, $writefh)
	or return undef;
    ($readfh, $writefh);
}

sub _open_mode_string {
    my ($mode) = @_;
    $mode =~ /^\+?(<|>>?)$/
      or $mode =~ s/^r(\+?)$/$1</
      or $mode =~ s/^w(\+?)$/$1>/
      or $mode =~ s/^a(\+?)$/$1>>/
      or croak "FileHandle: bad open mode: $mode";
    $mode;
}

sub open {
    @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
    my ($fh, $file) = @_;
    if (@_ > 2) {
	my ($mode, $perms) = @_[2, 3];
	if ($mode =~ /^\d+$/) {
	    defined $perms or $perms = 0666;
	    return sysopen($fh, $file, $mode, $perms);
	}
        $file = "./" . $file unless $file =~ m#^/#;
	$file = _open_mode_string($mode) . " $file\0";
    }
    open($fh, $file);
}

sub fdopen {
    @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
    my ($fh, $fd, $mode) = @_;
    if (ref($fd) =~ /GLOB\(/) {
	# It's a glob reference; remove the star from its name.
	($fd = "".$$fd) =~ s/^\*//;
    } elsif ($fd =~ m#^\d+$#) {
	# It's an FD number; prefix with "=".
	$fd = "=$fd";
    }
    open($fh, _open_mode_string($mode) . '&' . $fd);
}

sub close {
    @_ == 1 or croak 'usage: $fh->close()';
    close($_[0]);
}

################################################
## Normal I/O functions.
##

sub fileno {
    @_ == 1 or croak 'usage: $fh->fileno()';
    fileno($_[0]);
}

sub getc {
    @_ == 1 or croak 'usage: $fh->getc()';
    getc($_[0]);
}

sub gets {
    @_ == 1 or croak 'usage: $fh->gets()';
    my ($handle) = @_;
    scalar <$handle>;
}

sub eof {
    @_ == 1 or croak 'usage: $fh->eof()';
    eof($_[0]);
}

sub clearerr {
    @_ == 1 or croak 'usage: $fh->clearerr()';
    seek($_[0], 0, 1);
}

sub seek {
    @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
    seek($_[0], $_[1], $_[2]);
}

sub tell {
    @_ == 1 or croak 'usage: $fh->tell()';
    tell($_[0]);
}

sub print {
    @_ or croak 'usage: $fh->print([ARGS])';
    my $this = shift;
    print $this @_;
}

sub printf {
    @_ or croak 'usage: $fh->printf([ARGS])';
    my $this = shift;
    printf $this @_;
}

sub getline {
    @_ == 1 or croak 'usage: $fh->getline';
    my $this = shift;
    return scalar <$this>;
} 

sub getlines {
    @_ == 1 or croak 'usage: $fh->getline()';
    my $this = shift;
    wantarray or croak "Can't call FileHandle::getlines in a scalar context";
    return <$this>;
}

################################################
## State modification functions.
##

sub autoflush {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $OUTPUT_AUTOFLUSH;
    $OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
    $prev;
}

sub output_field_separator {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $OUTPUT_FIELD_SEPARATOR;
    $OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
    $prev;
}

sub output_record_separator {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $OUTPUT_RECORD_SEPARATOR;
    $OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
    $prev;
}

sub input_record_separator {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $INPUT_RECORD_SEPARATOR;
    $INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
    $prev;
}

sub input_line_number {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $INPUT_LINE_NUMBER;
    $INPUT_LINE_NUMBER = $_[1] if @_ > 1;
    $prev;
}

sub format_page_number {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $FORMAT_PAGE_NUMBER;
    $FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
    $prev;
}

sub format_lines_per_page {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $FORMAT_LINES_PER_PAGE;
    $FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
    $prev;
}

sub format_lines_left {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $FORMAT_LINES_LEFT;
    $FORMAT_LINES_LEFT = $_[1] if @_ > 1;
    $prev;
}

sub format_name {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $FORMAT_NAME;
    $FORMAT_NAME = qualify($_[1], caller) if @_ > 1;
    $prev;
}

sub format_top_name {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $FORMAT_TOP_NAME;
    $FORMAT_TOP_NAME = qualify($_[1], caller) if @_ > 1;
    $prev;
}

sub format_line_break_characters {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $FORMAT_LINE_BREAK_CHARACTERS;
    $FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
    $prev;
}

sub format_formfeed {
    my $old = new SelectSaver qualify($_[0], caller);
    my $prev = $FORMAT_FORMFEED;
    $FORMAT_FORMFEED = $_[1] if @_ > 1;
    $prev;
}

1;
Commit	Line	Data
c07a80fd	1	package FileHandle;
	2
	3	=head1 NAME
	4
	5	FileHandle - supply object methods for filehandles
	6
	7	=head1 SYNOPSIS
	8
	9	use FileHandle;
	10
	11	$fh = new FileHandle;
	12	if ($fh->open "< file") {
	13	print <$fh>;
	14	$fh->close;
	15	}
	16
	17	$fh = new FileHandle "> FOO";
	18	if (defined $fh) {
	19	print $fh "bar\n";
	20	$fh->close;
	21	}
	22
	23	$fh = new FileHandle "file", "r";
	24	if (defined $fh) {
	25	print <$fh>;
	26	undef $fh; # automatically closes the file
	27	}
	28
	29	$fh = new FileHandle "file", O_WRONLY\|O_APPEND;
	30	if (defined $fh) {
	31	print $fh "corge\n";
	32	undef $fh; # automatically closes the file
	33	}
	34
	35	($readfh, $writefh) = FileHandle::pipe;
	36
	37	autoflush STDOUT 1;
	38
	39	=head1 DESCRIPTION
	40
	41	C<FileHandle::new> creates a C<FileHandle>, which is a reference to a
	42	newly created symbol (see the C<Symbol> package). If it receives any
	43	parameters, they are passed to C<FileHandle::open>; if the open fails,
	44	the C<FileHandle> object is destroyed. Otherwise, it is returned to
	45	the caller.
	46
	47	C<FileHandle::new_from_fd> creates a C<FileHandle> like C<new> does.
	48	It requires two parameters, which are passed to C<FileHandle::fdopen>;
	49	if the fdopen fails, the C<FileHandle> object is destroyed.
	50	Otherwise, it is returned to the caller.
	51
	52	C<FileHandle::open> accepts one parameter or two. With one parameter,
	53	it is just a front end for the built-in C<open> function. With two
	54	parameters, the first parameter is a filename that may include
	55	whitespace or other special characters, and the second parameter is
	56	the open mode in either Perl form (">", "+<", etc.) or POSIX form
	57	("w", "r+", etc.).
	58
	59	C<FileHandle::fdopen> is like C<open> except that its first parameter
	60	is not a filename but rather a file handle name, a FileHandle object,
	61	or a file descriptor number.
	62
	63	See L<perlfunc> for complete descriptions of each of the following
	64	supported C<FileHandle> methods, which are just front ends for the
65	corresponding built-in functions:
66
67	close
68	fileno
69	getc
70	gets
71	eof
72	clearerr
73	seek
74	tell
75
76	See L<perlvar> for complete descriptions of each of the following
77	supported C<FileHandle> methods:
78
79	autoflush
80	output_field_separator
81	output_record_separator
82	input_record_separator
83	input_line_number
84	format_page_number
85	format_lines_per_page
86	format_lines_left
87	format_name
88	format_top_name
89	format_line_break_characters
90	format_formfeed
91
92	Furthermore, for doing normal I/O you might need these:
93
94	=over
95
96	=item $fh->print
97
98	See L<perlfunc/print>.
99
100	=item $fh->printf
101
102	See L<perlfunc/printf>.
103
104	=item $fh->getline
105
106	This works like <$fh> described in L<perlop/"I/O Operators">
107	except that it's more readable and can be safely called in an
108	array context but still returns just one line.
109
110	=item $fh->getlines
111
112	This works like <$fh> when called in an array context to
113	read all the remaining lines in a file, except that it's more readable.
114	It will also croak() if accidentally called in a scalar context.
115
116	=back
117
118	=head1 SEE ALSO
119
120	L<perlfunc>,
121	L<perlop/"I/O Operators">,
122	L<POSIX/"FileHandle">
123
124	=head1 BUGS
125
126	Due to backwards compatibility, all filehandles resemble objects
127	of class C<FileHandle>, or actually classes derived from that class.
128	They actually aren't. Which means you can't derive your own
129	class from C<FileHandle> and inherit those methods.
130
131	=cut
132
133	require 5.000;
134	use Carp;
135	use Fcntl;
136	use Symbol;
137	use English;
138	use SelectSaver;
139
140	require Exporter;
141	require DynaLoader;
142	@ISA = qw(Exporter DynaLoader);
143
144	@EXPORT = (@Fcntl::EXPORT,
145	qw(_IOFBF _IOLBF _IONBF));
146
147	@EXPORT_OK = qw(
148	autoflush
149	output_field_separator
150	output_record_separator
151	input_record_separator
152	input_line_number
153	format_page_number
154	format_lines_per_page
155	format_lines_left
156	format_name
157	format_top_name
158	format_line_break_characters
159	format_formfeed
160
161	print
162	printf
163	getline
164	getlines
165	);
166
167
168	################################################
169	## Interaction with the XS.
170	##
171
172	bootstrap FileHandle;
173
174	sub AUTOLOAD {
175	if ($AUTOLOAD =~ /::(_?[a-z])/) {
176	$AutoLoader::AUTOLOAD = $AUTOLOAD;
177	goto &AutoLoader::AUTOLOAD
178	}
179	my $constname = $AUTOLOAD;
180	$constname =~ s/.*:://;
181	my $val = constant($constname);
182	defined $val or croak "$constname is not a valid FileHandle macro";
183	*$AUTOLOAD = sub { $val };
184	goto &$AUTOLOAD;
185	}
186
187
188	################################################
189	## Constructors, destructors.
190	##
191
192	sub new {
193	@_ >= 1 && @_ <= 3 or croak 'usage: new FileHandle [FILENAME [,MODE]]';
194	my $class = shift;
195	my $fh = gensym;
196	if (@_) {
197	FileHandle::open($fh, @_)
198	or return undef;
199	}
200	bless $fh, $class;
201	}
202
203	sub new_from_fd {
204	@_ == 3 or croak 'usage: new_from_fd FileHandle FD, MODE';
205	my $class = shift;
206	my $fh = gensym;
207	FileHandle::fdopen($fh, @_)
208	or return undef;
209	bless $fh, $class;
210	}
211
212	sub DESTROY {
213	my ($fh) = @_;
214	close($fh);
215	}
216
217	################################################
218	## Open and close.
219	##
220
221	sub pipe {
222	@_ and croak 'usage: FileHandle::pipe()';
223	my $readfh = new FileHandle;
224	my $writefh = new FileHandle;
225	pipe($readfh, $writefh)
226	or return undef;
227	($readfh, $writefh);
228	}
229
230	sub _open_mode_string {
231	my ($mode) = @_;
232	$mode =~ /^\+?(<\|>>?)$/
233	or $mode =~ s/^r(\+?)$/$1</
234	or $mode =~ s/^w(\+?)$/$1>/
235	or $mode =~ s/^a(\+?)$/$1>>/
236	or croak "FileHandle: bad open mode: $mode";
237	$mode;
238	}
239
240	sub open {
241	@_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
242	my ($fh, $file) = @_;
243	if (@_ > 2) {
244	my ($mode, $perms) = @_[2, 3];
245	if ($mode =~ /^\d+$/) {
246	defined $perms or $perms = 0666;
247	return sysopen($fh, $file, $mode, $perms);
248	}
249	$file = "./" . $file unless $file =~ m#^/#;
250	$file = _open_mode_string($mode) . " $file\0";
251	}
252	open($fh, $file);
253	}
254
255	sub fdopen {
256	@_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
257	my ($fh, $fd, $mode) = @_;
258	if (ref($fd) =~ /GLOB\(/) {
259	# It's a glob reference; remove the star from its name.
260	($fd = "".$$fd) =~ s/^\*//;
261	} elsif ($fd =~ m#^\d+$#) {
262	# It's an FD number; prefix with "=".
263	$fd = "=$fd";
264	}
265	open($fh, _open_mode_string($mode) . '&' . $fd);
266	}
267
268	sub close {
269	@_ == 1 or croak 'usage: $fh->close()';
270	close($_[0]);
271	}
272
273	################################################
274	## Normal I/O functions.
275	##
276
277	sub fileno {
278	@_ == 1 or croak 'usage: $fh->fileno()';
279	fileno($_[0]);
280	}
281
282	sub getc {
283	@_ == 1 or croak 'usage: $fh->getc()';
284	getc($_[0]);
285	}
286
287	sub gets {
288	@_ == 1 or croak 'usage: $fh->gets()';
289	my ($handle) = @_;
290	scalar <$handle>;
291	}
292
293	sub eof {
294	@_ == 1 or croak 'usage: $fh->eof()';
295	eof($_[0]);
296	}
297
298	sub clearerr {
299	@_ == 1 or croak 'usage: $fh->clearerr()';
300	seek($_[0], 0, 1);
301	}
302
303	sub seek {
304	@_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
305	seek($_[0], $_[1], $_[2]);
306	}
307
308	sub tell {
309	@_ == 1 or croak 'usage: $fh->tell()';
310	tell($_[0]);
311	}
312
313	sub print {
314	@_ or croak 'usage: $fh->print([ARGS])';
315	my $this = shift;
316	print $this @_;
317	}
318
319	sub printf {
320	@_ or croak 'usage: $fh->printf([ARGS])';
321	my $this = shift;
322	printf $this @_;
323	}
324
325	sub getline {
326	@_ == 1 or croak 'usage: $fh->getline';
327	my $this = shift;
328	return scalar <$this>;
329	}
330
331	sub getlines {
332	@_ == 1 or croak 'usage: $fh->getline()';
333	my $this = shift;
334	wantarray or croak "Can't call FileHandle::getlines in a scalar context";
335	return <$this>;
336	}
337
338	################################################
339	## State modification functions.
340	##
341
342	sub autoflush {
343	my $old = new SelectSaver qualify($_[0], caller);
344	my $prev = $OUTPUT_AUTOFLUSH;
345	$OUTPUT_AUTOFLUSH = @_ > 1 ? $_[1] : 1;
346	$prev;
347	}
348
349	sub output_field_separator {
350	my $old = new SelectSaver qualify($_[0], caller);
351	my $prev = $OUTPUT_FIELD_SEPARATOR;
352	$OUTPUT_FIELD_SEPARATOR = $_[1] if @_ > 1;
353	$prev;
354	}
355
356	sub output_record_separator {
357	my $old = new SelectSaver qualify($_[0], caller);
358	my $prev = $OUTPUT_RECORD_SEPARATOR;
359	$OUTPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
360	$prev;
361	}
362
363	sub input_record_separator {
364	my $old = new SelectSaver qualify($_[0], caller);
365	my $prev = $INPUT_RECORD_SEPARATOR;
366	$INPUT_RECORD_SEPARATOR = $_[1] if @_ > 1;
367	$prev;
368	}
369
370	sub input_line_number {
371	my $old = new SelectSaver qualify($_[0], caller);
372	my $prev = $INPUT_LINE_NUMBER;
373	$INPUT_LINE_NUMBER = $_[1] if @_ > 1;
374	$prev;
375	}
376
377	sub format_page_number {
378	my $old = new SelectSaver qualify($_[0], caller);
379	my $prev = $FORMAT_PAGE_NUMBER;
380	$FORMAT_PAGE_NUMBER = $_[1] if @_ > 1;
381	$prev;
382	}
383
384	sub format_lines_per_page {
385	my $old = new SelectSaver qualify($_[0], caller);
386	my $prev = $FORMAT_LINES_PER_PAGE;
387	$FORMAT_LINES_PER_PAGE = $_[1] if @_ > 1;
388	$prev;
389	}
390
391	sub format_lines_left {
392	my $old = new SelectSaver qualify($_[0], caller);
393	my $prev = $FORMAT_LINES_LEFT;
394	$FORMAT_LINES_LEFT = $_[1] if @_ > 1;
395	$prev;
396	}
397
398	sub format_name {
399	my $old = new SelectSaver qualify($_[0], caller);
400	my $prev = $FORMAT_NAME;
401	$FORMAT_NAME = qualify($_[1], caller) if @_ > 1;
402	$prev;
403	}
404
405	sub format_top_name {
406	my $old = new SelectSaver qualify($_[0], caller);
407	my $prev = $FORMAT_TOP_NAME;
408	$FORMAT_TOP_NAME = qualify($_[1], caller) if @_ > 1;
409	$prev;
410	}
411
412	sub format_line_break_characters {
413	my $old = new SelectSaver qualify($_[0], caller);
414	my $prev = $FORMAT_LINE_BREAK_CHARACTERS;
415	$FORMAT_LINE_BREAK_CHARACTERS = $_[1] if @_ > 1;
416	$prev;
417	}
418
419	sub format_formfeed {
420	my $old = new SelectSaver qualify($_[0], caller);
421	my $prev = $FORMAT_FORMFEED;
422	$FORMAT_FORMFEED = $_[1] if @_ > 1;
423	$prev;
424	}
425
426	1;