home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Spool.pm < prev    next >
Encoding:
Perl POD Document  |  2002-12-13  |  3.1 KB  |  114 lines
  1. #
  2. # Package meta, adds meta database commands to dbish
  3. #
  4. package DBI::Shell::Spool;
  5.  
  6. use strict;
  7. use vars qw(@ISA $VERSION);
  8.  
  9. use IO::Tee;
  10.  
  11. $VERSION = sprintf( "%d.%02d", q$Revision: 11.91 $ =~ /(\d+)\.(\d+)/ );
  12.  
  13. sub init {
  14.     my ($self, $sh, @arg)  = @_;
  15.  
  16.  
  17.     $sh->install_options( 
  18.     [
  19.         [ 'spool'            => 'off'    ],
  20.     ]);
  21.     my $com_ref = $sh->{commands};
  22.     $com_ref->{spool}        = { 
  23.         hint => 
  24.             "spool: on/off or file name to send output to",
  25.     };
  26.         
  27.     return $self;
  28. }
  29.  
  30. #------------------------------------------------------------------
  31. #
  32. # Start or Stop spooling output.
  33. # The spool support the follow states:
  34. # spool - returns the current state of spooling, if on includes the file name.
  35. # spool on - set the state to on, opens a default name of spool.lst (Yes, the
  36. # Oracle default name).  If the spool current state is already on, returns a
  37. # warning message (Already spooling to file X).
  38. # spool /path/file/name - set the state on, attempt to open the file name
  39. # (using the IO::Tee object to allow multiplex output), and set the new IO
  40. # handle to the default handle.
  41. # spool off - set the state to off.  If the previous state was on, flush the
  42. # current buffer and close the file handle.  If the previous state was off,
  43. # return a warning message (Not current spooling).
  44. #
  45. #------------------------------------------------------------------
  46. sub do_spool {
  47.     my ($sh, @args) = @_;
  48.  
  49. # Get the current state of spool.
  50.     unless(@args) {
  51.         if ($sh->is_spooling) {
  52.             return $sh->print_buffer( qq{spooling output to file: },
  53.             $sh->{spool_file} );
  54.         } else {
  55.             return $sh->print_buffer( qq{not spooling} );
  56.         }
  57.     }
  58.  
  59. # So what command did I get at this point?
  60.     my $command = shift @args;
  61.  
  62.     if ($command =~ m/\boff/i) {    # Turn the spool off (if on).
  63.         if ($sh->is_spooling) { # spool on
  64.             # The tee object contains the open handles, get a list, shift the
  65.             # first (this should be STDOUT), flush.  Then for the remainder
  66.             # flush each and close.
  67.             my @fhs = $sh->{out_fh}->handles;
  68.             $sh->{out_fh} = shift @fhs; select $sh->{out_fh};
  69.  
  70.             $sh->{out_fh}->flush;
  71.             $sh->spool_off; $sh->{spool_file} = undef;
  72.             foreach my $fh (@fhs) {
  73.                 $fh->flush;
  74.                 $fh->close;
  75.             }
  76.             $sh->{spool_fh} = undef;
  77.             return $sh->{out_fh};
  78.         }
  79.         return $sh->print_buffer( qq{not spooling} );
  80.     }
  81.  
  82.     my $spool_file = undef;
  83.     if ($command =~ m/on/i) {    # Turn the spool off (if on).
  84.         unless(@args or $args[0] !~ m/!/) {
  85.             $spool_file = q{on.lst};
  86.         }
  87.     }
  88.  
  89.     # OK, now we're at the one to open the spool file.  How do I handle if the
  90.     # file exists? Well, unless the next arg is a !, open the file for append.
  91.     my $mode = q{a+};
  92.     if (@args and $args[0] =~ m/!/) {
  93.         shift @args; 
  94.         $mode = q{w};
  95.     }
  96.     
  97.     my $out_fh        = $sh->{out_fh};
  98.  
  99.     $spool_file = defined $spool_file ? $spool_file : $command;
  100.  
  101.     if (defined $spool_file) {
  102.         my $tee_fh = new IO::Tee($out_fh, new IO::File($spool_file, $mode)) or
  103.             return $sh->alert(qq{Unable create IO::Tee ($spool_file) handle: $!\n});
  104.         $sh->{out_fh} = $tee_fh;
  105.         $sh->{spool_file} = $spool_file; $sh->spool_on;
  106.         $sh->{spool_fh} = ($tee_fh->handles)[1];
  107.         select $tee_fh;
  108.         return $sh->print_buffer( qq{spooling $spool_file} );
  109.     }
  110. return $sh->alert( qq{spool command failed for unknown reason} );
  111. }
  112.  
  113. 1;
  114.