PageRenderTime 57ms CodeModel.GetById 21ms RepoModel.GetById 0ms app.codeStats 0ms

/ext/IO/lib/IO/Handle.pm

http://perl5005.googlecode.com/
Perl | 539 lines | 408 code | 105 blank | 26 comment | 76 complexity | a2697fc87c1d3a233afa06d8a883e8cb MD5 | raw file
Possible License(s): AGPL-1.0
  1. package IO::Handle;
  2. =head1 NAME
  3. IO::Handle - supply object methods for I/O handles
  4. =head1 SYNOPSIS
  5. use IO::Handle;
  6. $fh = new IO::Handle;
  7. if ($fh->fdopen(fileno(STDIN),"r")) {
  8. print $fh->getline;
  9. $fh->close;
  10. }
  11. $fh = new IO::Handle;
  12. if ($fh->fdopen(fileno(STDOUT),"w")) {
  13. $fh->print("Some text\n");
  14. }
  15. use IO::Handle '_IOLBF';
  16. $fh->setvbuf($buffer_var, _IOLBF, 1024);
  17. undef $fh; # automatically closes the file if it's open
  18. autoflush STDOUT 1;
  19. =head1 DESCRIPTION
  20. C<IO::Handle> is the base class for all other IO handle classes. It is
  21. not intended that objects of C<IO::Handle> would be created directly,
  22. but instead C<IO::Handle> is inherited from by several other classes
  23. in the IO hierarchy.
  24. If you are reading this documentation, looking for a replacement for
  25. the C<FileHandle> package, then I suggest you read the documentation
  26. for C<IO::File>
  27. A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package)
  28. =head1 CONSTRUCTOR
  29. =over 4
  30. =item new ()
  31. Creates a new C<IO::Handle> object.
  32. =item new_from_fd ( FD, MODE )
  33. Creates a C<IO::Handle> like C<new> does.
  34. It requires two parameters, which are passed to the method C<fdopen>;
  35. if the fdopen fails, the object is destroyed. Otherwise, it is returned
  36. to the caller.
  37. =back
  38. =head1 METHODS
  39. See L<perlfunc> for complete descriptions of each of the following
  40. supported C<IO::Handle> methods, which are just front ends for the
  41. corresponding built-in functions:
  42. close
  43. fileno
  44. getc
  45. eof
  46. read
  47. truncate
  48. stat
  49. print
  50. printf
  51. sysread
  52. syswrite
  53. See L<perlvar> for complete descriptions of each of the following
  54. supported C<IO::Handle> methods:
  55. autoflush
  56. output_field_separator
  57. output_record_separator
  58. input_record_separator
  59. input_line_number
  60. format_page_number
  61. format_lines_per_page
  62. format_lines_left
  63. format_name
  64. format_top_name
  65. format_line_break_characters
  66. format_formfeed
  67. format_write
  68. Furthermore, for doing normal I/O you might need these:
  69. =over
  70. =item $fh->fdopen ( FD, MODE )
  71. C<fdopen> is like an ordinary C<open> except that its first parameter
  72. is not a filename but rather a file handle name, a IO::Handle object,
  73. or a file descriptor number.
  74. =item $fh->opened
  75. Returns true if the object is currently a valid file descriptor.
  76. =item $fh->getline
  77. This works like <$fh> described in L<perlop/"I/O Operators">
  78. except that it's more readable and can be safely called in an
  79. array context but still returns just one line.
  80. =item $fh->getlines
  81. This works like <$fh> when called in an array context to
  82. read all the remaining lines in a file, except that it's more readable.
  83. It will also croak() if accidentally called in a scalar context.
  84. =item $fh->ungetc ( ORD )
  85. Pushes a character with the given ordinal value back onto the given
  86. handle's input stream.
  87. =item $fh->write ( BUF, LEN [, OFFSET }\] )
  88. This C<write> is like C<write> found in C, that is it is the
  89. opposite of read. The wrapper for the perl C<write> function is
  90. called C<format_write>.
  91. =item $fh->flush
  92. Flush the given handle's buffer.
  93. =item $fh->error
  94. Returns a true value if the given handle has experienced any errors
  95. since it was opened or since the last call to C<clearerr>.
  96. =item $fh->clearerr
  97. Clear the given handle's error indicator.
  98. =back
  99. If the C functions setbuf() and/or setvbuf() are available, then
  100. C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
  101. policy for an IO::Handle. The calling sequences for the Perl functions
  102. are the same as their C counterparts--including the constants C<_IOFBF>,
  103. C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
  104. specifies a scalar variable to use as a buffer. WARNING: A variable
  105. used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any
  106. way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called
  107. again, or memory corruption may result! Note that you need to import
  108. the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly.
  109. Lastly, there is a special method for working under B<-T> and setuid/gid
  110. scripts:
  111. =over
  112. =item $fh->untaint
  113. Marks the object as taint-clean, and as such data read from it will also
  114. be considered taint-clean. Note that this is a very trusting action to
  115. take, and appropriate consideration for the data source and potential
  116. vulnerability should be kept in mind.
  117. =back
  118. =head1 NOTE
  119. A C<IO::Handle> object is a GLOB reference. Some modules that
  120. inherit from C<IO::Handle> may want to keep object related variables
  121. in the hash table part of the GLOB. In an attempt to prevent modules
  122. trampling on each other I propose the that any such module should prefix
  123. its variables with its own name separated by _'s. For example the IO::Socket
  124. module keeps a C<timeout> variable in 'io_socket_timeout'.
  125. =head1 SEE ALSO
  126. L<perlfunc>,
  127. L<perlop/"I/O Operators">,
  128. L<IO::File>
  129. =head1 BUGS
  130. Due to backwards compatibility, all filehandles resemble objects
  131. of class C<IO::Handle>, or actually classes derived from that class.
  132. They actually aren't. Which means you can't derive your own
  133. class from C<IO::Handle> and inherit those methods.
  134. =head1 HISTORY
  135. Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
  136. =cut
  137. require 5.000;
  138. use strict;
  139. use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA);
  140. use Carp;
  141. use Symbol;
  142. use SelectSaver;
  143. require Exporter;
  144. @ISA = qw(Exporter);
  145. $VERSION = "1.1505";
  146. $XS_VERSION = "1.15";
  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. format_write
  161. print
  162. printf
  163. getline
  164. getlines
  165. SEEK_SET
  166. SEEK_CUR
  167. SEEK_END
  168. _IOFBF
  169. _IOLBF
  170. _IONBF
  171. );
  172. ################################################
  173. ## Interaction with the XS.
  174. ##
  175. require DynaLoader;
  176. @IO::ISA = qw(DynaLoader);
  177. bootstrap IO $XS_VERSION;
  178. sub AUTOLOAD {
  179. if ($AUTOLOAD =~ /::(_?[a-z])/) {
  180. $AutoLoader::AUTOLOAD = $AUTOLOAD;
  181. goto &AutoLoader::AUTOLOAD
  182. }
  183. my $constname = $AUTOLOAD;
  184. $constname =~ s/.*:://;
  185. my $val = constant($constname);
  186. defined $val or croak "$constname is not a valid IO::Handle macro";
  187. no strict 'refs';
  188. *$AUTOLOAD = sub { $val };
  189. goto &$AUTOLOAD;
  190. }
  191. ################################################
  192. ## Constructors, destructors.
  193. ##
  194. sub new {
  195. my $class = ref($_[0]) || $_[0] || "IO::Handle";
  196. @_ == 1 or croak "usage: new $class";
  197. my $fh = gensym;
  198. bless $fh, $class;
  199. }
  200. sub new_from_fd {
  201. my $class = ref($_[0]) || $_[0] || "IO::Handle";
  202. @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
  203. my $fh = gensym;
  204. shift;
  205. IO::Handle::fdopen($fh, @_)
  206. or return undef;
  207. bless $fh, $class;
  208. }
  209. #
  210. # There is no need for DESTROY to do anything, because when the
  211. # last reference to an IO object is gone, Perl automatically
  212. # closes its associated files (if any). However, to avoid any
  213. # attempts to autoload DESTROY, we here define it to do nothing.
  214. #
  215. sub DESTROY {}
  216. ################################################
  217. ## Open and close.
  218. ##
  219. sub _open_mode_string {
  220. my ($mode) = @_;
  221. $mode =~ /^\+?(<|>>?)$/
  222. or $mode =~ s/^r(\+?)$/$1</
  223. or $mode =~ s/^w(\+?)$/$1>/
  224. or $mode =~ s/^a(\+?)$/$1>>/
  225. or croak "IO::Handle: bad open mode: $mode";
  226. $mode;
  227. }
  228. sub fdopen {
  229. @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
  230. my ($fh, $fd, $mode) = @_;
  231. local(*GLOB);
  232. if (ref($fd) && "".$fd =~ /GLOB\(/o) {
  233. # It's a glob reference; Alias it as we cannot get name of anon GLOBs
  234. my $n = qualify(*GLOB);
  235. *GLOB = *{*$fd};
  236. $fd = $n;
  237. } elsif ($fd =~ m#^\d+$#) {
  238. # It's an FD number; prefix with "=".
  239. $fd = "=$fd";
  240. }
  241. open($fh, _open_mode_string($mode) . '&' . $fd)
  242. ? $fh : undef;
  243. }
  244. sub close {
  245. @_ == 1 or croak 'usage: $fh->close()';
  246. my($fh) = @_;
  247. close($fh);
  248. }
  249. ################################################
  250. ## Normal I/O functions.
  251. ##
  252. # flock
  253. # select
  254. sub opened {
  255. @_ == 1 or croak 'usage: $fh->opened()';
  256. defined fileno($_[0]);
  257. }
  258. sub fileno {
  259. @_ == 1 or croak 'usage: $fh->fileno()';
  260. fileno($_[0]);
  261. }
  262. sub getc {
  263. @_ == 1 or croak 'usage: $fh->getc()';
  264. getc($_[0]);
  265. }
  266. sub eof {
  267. @_ == 1 or croak 'usage: $fh->eof()';
  268. eof($_[0]);
  269. }
  270. sub print {
  271. @_ or croak 'usage: $fh->print([ARGS])';
  272. my $this = shift;
  273. print $this @_;
  274. }
  275. sub printf {
  276. @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])';
  277. my $this = shift;
  278. printf $this @_;
  279. }
  280. sub getline {
  281. @_ == 1 or croak 'usage: $fh->getline';
  282. my $this = shift;
  283. return scalar <$this>;
  284. }
  285. *gets = \&getline; # deprecated
  286. sub getlines {
  287. @_ == 1 or croak 'usage: $fh->getline()';
  288. wantarray or
  289. croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline';
  290. my $this = shift;
  291. return <$this>;
  292. }
  293. sub truncate {
  294. @_ == 2 or croak 'usage: $fh->truncate(LEN)';
  295. truncate($_[0], $_[1]);
  296. }
  297. sub read {
  298. @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])';
  299. read($_[0], $_[1], $_[2], $_[3] || 0);
  300. }
  301. sub sysread {
  302. @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])';
  303. sysread($_[0], $_[1], $_[2], $_[3] || 0);
  304. }
  305. sub write {
  306. @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])';
  307. local($\) = "";
  308. print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
  309. }
  310. sub syswrite {
  311. @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])';
  312. syswrite($_[0], $_[1], $_[2], $_[3] || 0);
  313. }
  314. sub stat {
  315. @_ == 1 or croak 'usage: $fh->stat()';
  316. stat($_[0]);
  317. }
  318. ################################################
  319. ## State modification functions.
  320. ##
  321. sub autoflush {
  322. my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
  323. my $prev = $|;
  324. $| = @_ > 1 ? $_[1] : 1;
  325. $prev;
  326. }
  327. sub output_field_separator {
  328. my $prev = $,;
  329. $, = $_[1] if @_ > 1;
  330. $prev;
  331. }
  332. sub output_record_separator {
  333. my $prev = $\;
  334. $\ = $_[1] if @_ > 1;
  335. $prev;
  336. }
  337. sub input_record_separator {
  338. my $prev = $/;
  339. $/ = $_[1] if @_ > 1;
  340. $prev;
  341. }
  342. sub input_line_number {
  343. # localizing $. doesn't work as advertised. grrrrrr.
  344. my $prev = $.;
  345. $. = $_[1] if @_ > 1;
  346. $prev;
  347. }
  348. sub format_page_number {
  349. my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
  350. my $prev = $%;
  351. $% = $_[1] if @_ > 1;
  352. $prev;
  353. }
  354. sub format_lines_per_page {
  355. my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
  356. my $prev = $=;
  357. $= = $_[1] if @_ > 1;
  358. $prev;
  359. }
  360. sub format_lines_left {
  361. my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
  362. my $prev = $-;
  363. $- = $_[1] if @_ > 1;
  364. $prev;
  365. }
  366. sub format_name {
  367. my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
  368. my $prev = $~;
  369. $~ = qualify($_[1], caller) if @_ > 1;
  370. $prev;
  371. }
  372. sub format_top_name {
  373. my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]);
  374. my $prev = $^;
  375. $^ = qualify($_[1], caller) if @_ > 1;
  376. $prev;
  377. }
  378. sub format_line_break_characters {
  379. my $prev = $:;
  380. $: = $_[1] if @_ > 1;
  381. $prev;
  382. }
  383. sub format_formfeed {
  384. my $prev = $^L;
  385. $^L = $_[1] if @_ > 1;
  386. $prev;
  387. }
  388. sub formline {
  389. my $fh = shift;
  390. my $picture = shift;
  391. local($^A) = $^A;
  392. local($\) = "";
  393. formline($picture, @_);
  394. print $fh $^A;
  395. }
  396. sub format_write {
  397. @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )';
  398. if (@_ == 2) {
  399. my ($fh, $fmt) = @_;
  400. my $oldfmt = $fh->format_name($fmt);
  401. CORE::write($fh);
  402. $fh->format_name($oldfmt);
  403. } else {
  404. CORE::write($_[0]);
  405. }
  406. }
  407. sub fcntl {
  408. @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );';
  409. my ($fh, $op, $val) = @_;
  410. my $r = fcntl($fh, $op, $val);
  411. defined $r && $r eq "0 but true" ? 0 : $r;
  412. }
  413. sub ioctl {
  414. @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );';
  415. my ($fh, $op, $val) = @_;
  416. my $r = ioctl($fh, $op, $val);
  417. defined $r && $r eq "0 but true" ? 0 : $r;
  418. }
  419. 1;