cmd.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

    ### Perl Monastery (http://www.perlmonks.org/index.pl?node_id=151886).
    ### XXX that code didn't work.
    ### we now use the following code, thanks to theorbtwo

    ### define them beforehand, so we always have defined FH's
    ### to read from.
    use Symbol;    
    my $kidout      = Symbol::gensym();
    my $kiderror    = Symbol::gensym();

    ### Dup the filehandle so we can pass 'our' STDIN to the
    ### child process. This stops us from having to pump input
    ### from ourselves to the childprocess. However, we will need
    ### to revive the FH afterwards, as IPC::Open3 closes it.
    ### We'll do the same for STDOUT and STDERR. It works without
    ### duping them on non-unix derivatives, but not on win32.
    my @fds_to_dup = ( IS_WIN32 && !$verbose 
                            ? qw[STDIN STDOUT STDERR] 
                            : qw[STDIN]
                        );
    __PACKAGE__->__dup_fds( @fds_to_dup );
    

    my $pid = IPC::Open3::open3(
                    '<&STDIN',
                    (IS_WIN32 ? '>&STDOUT' : $kidout),
                    (IS_WIN32 ? '>&STDERR' : $kiderror),
                    $cmd
                );

    ### use OUR stdin, not $kidin. Somehow,
    ### we never get the input.. so jump through
    ### some hoops to do it :(
    my $selector = IO::Select->new(
                        (IS_WIN32 ? \*STDERR : $kiderror), 
                        \*STDIN,   
                        (IS_WIN32 ? \*STDOUT : $kidout)     
                    );              

    STDOUT->autoflush(1);   STDERR->autoflush(1);   STDIN->autoflush(1);
    $kidout->autoflush(1)   if UNIVERSAL::can($kidout,   'autoflush');
    $kiderror->autoflush(1) if UNIVERSAL::can($kiderror, 'autoflush');

    ### add an epxlicit break statement
    ### code courtesy of theorbtwo from #london.pm
    my $stdout_done = 0;
    my $stderr_done = 0;
    OUTER: while ( my @ready = $selector->can_read ) {

        for my $h ( @ready ) {
            my $buf;
            
            ### $len is the amount of bytes read
            my $len = sysread( $h, $buf, 4096 );    # try to read 4096 bytes
            
            ### see perldoc -f sysread: it returns undef on error,
            ### so bail out.
            if( not defined $len ) {
                warn(loc("Error reading from process: %1", $!));
                last OUTER;
            }
            
            ### check for $len. it may be 0, at which point we're
            ### done reading, so don't try to process it.
            ### if we would print anyway, we'd provide bogus information
            $_out_handler->( "$buf" ) if $len && $h == $kidout;
            $_err_handler->( "$buf" ) if $len && $h == $kiderror;

            ### Wait till child process is done printing to both
            ### stdout and stderr.
            $stdout_done = 1 if $h == $kidout   and $len == 0;
            $stderr_done = 1 if $h == $kiderror and $len == 0;
            last OUTER if ($stdout_done && $stderr_done);
        }
    }

    waitpid $pid, 0; # wait for it to die

    ### restore STDIN after duping, or STDIN will be closed for
    ### this current perl process!
    __PACKAGE__->__reopen_fds( @fds_to_dup );
    
    return if $?;   # some error occurred
    return 1;
}


sub _ipc_run {  
    my $self            = shift;
    my $cmd             = shift;
    my $_out_handler    = shift;
    my $_err_handler    = shift;
    
    STDOUT->autoflush(1); STDERR->autoflush(1);

    ### a command like:
    # [
    #     '/usr/bin/gzip',
    #     '-cdf',
    #     '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz',
    #     '|',
    #     '/usr/bin/tar',
    #     '-tf -'
    # ]
    ### needs to become:
    # [
    #     ['/usr/bin/gzip', '-cdf',
    #       '/Users/kane/sources/p4/other/archive-extract/t/src/x.tgz']
    #     '|',
    #     ['/usr/bin/tar', '-tf -']
    # ]

    
    my @command; my $special_chars;
    if( ref $cmd ) {
        my $aref = [];
        for my $item (@$cmd) {
            if( $item =~ /([<>|&])/ ) {
                push @command, $aref, $item;
                $aref = [];
                $special_chars .= $1;
            } else {
                push @$aref, $item;
            }
        }
        push @command, $aref;
    } else {
        @command = map { if( /([<>|&])/ ) {
                            $special_chars .= $1; $_;
                         } else {
                            [ split / +/ ]
                         }
                    } split( /\s*([<>|&])\s*/, $cmd );
    }
 
    ### if there's a pipe in the command, *STDIN needs to 
    ### be inserted *BEFORE* the pipe, to work on win32
    ### this also works on *nix, so we should do it when possible
    ### this should *also* work on multiple pipes in the command
    ### if there's no pipe in the command, append STDIN to the back
    ### of the command instead.
    ### XXX seems IPC::Run works it out for itself if you just
    ### dont pass STDIN at all.
    #     if( $special_chars and $special_chars =~ /\|/ ) {
    #         ### only add STDIN the first time..
    #         my $i;
    #         @command = map { ($_ eq '|' && not $i++) 
    #                             ? ( \*STDIN, $_ ) 
    #                             : $_ 
    #                         } @command; 
    #     } else {
    #         push @command, \*STDIN;
    #     }
  
 
    # \*STDIN is already included in the @command, see a few lines up
    return IPC::Run::run(   @command, 
                            fileno(STDOUT).'>',
                            $_out_handler,
                            fileno(STDERR).'>',
                            $_err_handler
                        );
}

sub _system_run { 
    my $self    = shift;
    my $cmd     = shift;
    my $verbose = shift || 0;

    my @fds_to_dup = $verbose ? () : qw[STDOUT STDERR];
    __PACKAGE__->__dup_fds( @fds_to_dup );
    
    ### system returns 'true' on failure -- the exit code of the cmd
    system( $cmd );
    
    __PACKAGE__->__reopen_fds( @fds_to_dup );
    
    return if $?;
    return 1;
}

{   use File::Spec;
    use Symbol;

    my %Map = (
        STDOUT => [qw|>&|, \*STDOUT, Symbol::gensym() ],
        STDERR => [qw|>&|, \*STDERR, Symbol::gensym() ],
        STDIN  => [qw|<&|, \*STDIN,  Symbol::gensym() ],
    );

    ### dups FDs and stores them in a cache
    sub __dup_fds {
        my $self    = shift;
        my @fds     = @_;

        __PACKAGE__->_debug( "# Closing the following fds: @fds" ) if $DEBUG;

        for my $name ( @fds ) {
            my($redir, $fh, $glob) = @{$Map{$name}} or (
                Carp::carp(loc("No such FD: '%1'", $name)), next );
            
            ### MUST use the 2-arg version of open for dup'ing for 
            ### 5.6.x compatibilty. 5.8.x can use 3-arg open
            ### see perldoc5.6.2 -f open for details            
            open $glob, $redir . fileno($fh) or (
                        Carp::carp(loc("Could not dup '$name': %1", $!)),
                        return
                    );        
                
            ### we should re-open this filehandle right now, not
            ### just dup it
            ### Use 2-arg version of open, as 5.5.x doesn't support
            ### 3-arg version =/
            if( $redir eq '>&' ) {
                open( $fh, '>' . File::Spec->devnull ) or (
                    Carp::carp(loc("Could not reopen '$name': %1", $!)),
                    return
                );
            }
        }
        
        return 1;
    }

    ### reopens FDs from the cache    
    sub __reopen_fds {
        my $self    = shift;
        my @fds     = @_;

        __PACKAGE__->_debug( "# Reopening the following fds: @fds" ) if $DEBUG;

        for my $name ( @fds ) {
            my($redir, $fh, $glob) = @{$Map{$name}} or (
                Carp::carp(loc("No such FD: '%1'", $name)), next );

            ### MUST use the 2-arg version of open for dup'ing for 
            ### 5.6.x compatibilty. 5.8.x can use 3-arg open
            ### see perldoc5.6.2 -f open for details
            open( $fh, $redir . fileno($glob) ) or (
                    Carp::carp(loc("Could not restore '$name': %1", $!)),
                    return
                ); 
           
            ### close this FD, we're not using it anymore
            close $glob;                
        }                
        return 1;                
    
    }
}    

sub _debug {
    my $self    = shift;
    my $msg     = shift or return;
    my $level   = shift || 0;
    
    local $Carp::CarpLevel += $level;
    Carp::carp($msg);
    
    return 1;
}


1;


__END__

=head1 HOW IT WORKS

C<run> will try to execute your command using the following logic:

=over 4

=item *

If you have C<IPC::Run> installed, and the variable C<$IPC::Cmd::USE_IPC_RUN>
is set to true (See the C<GLOBAL VARIABLES> Section) use that to execute 
the command. You will have the full output available in buffers, interactive commands are sure to work  and you are guaranteed to have your verbosity
settings honored cleanly.

=item *

Otherwise, if the variable C<$IPC::Cmd::USE_IPC_OPEN3> is set to true 
(See the C<GLOBAL VARIABLES> Section), try to execute the command using
C<IPC::Open3>. Buffers will be available on all platforms except C<Win32>,
interactive commands will still execute cleanly, and also your verbosity
settings will be adhered to nicely;

=item *

Otherwise, if you have the verbose argument set to true, we fall back
to a simple system() call. We cannot capture any buffers, but
interactive commands will still work.

=item *

Otherwise we will try and temporarily redirect STDERR and STDOUT, do a
system() call with your command and then re-open STDERR and STDOUT.
This is the method of last resort and will still allow you to execute
your commands cleanly. However, no buffers will be available.

=back

=head1 Global Variables

The behaviour of IPC::Cmd can be altered by changing the following
global variables:

=head2 $IPC::Cmd::VERBOSE

This controls whether IPC::Cmd will print any output from the
commands to the screen or not. The default is 0;

=head2 $IPC::Cmd::USE_IPC_RUN

This variable controls whether IPC::Cmd will try to use L<IPC::Run>
when available and suitable. Defaults to true if you are on C<Win32>.

=head2 $IPC::Cmd::USE_IPC_OPEN3

This variable controls whether IPC::Cmd will try to use L<IPC::Open3>
when available and suitable. Defaults to true.

=head2 $IPC::Cmd::WARN

This variable controls whether run time warnings should be issued, like
the failure to load an C<IPC::*> module you explicitly requested.

Defaults to true. Turn this off at your own risk.

=head1 Caveats

=over 4

=item Whitespace

When you provide a string as this argument, the string will be
split on whitespace to determine the individual elements of your
command. Although this will usually just Do What You Mean, it may
break if you have files or commands with whitespace in them.

If you do not wish this to happen, you should provide an array
reference, where all parts of your command are already separated out.
Note however, if there's extra or spurious whitespace in these parts,
the parser or underlying code may not interpret it correctly, and
cause an error.

Example:
The following code

    gzip -cdf foo.tar.gz | tar -xf -

should either be passed as

    "gzip -cdf foo.tar.gz | tar -xf -"

or as

    ['gzip', '-cdf', 'foo.tar.gz', '|', 'tar', '-xf', '-']

But take care not to pass it as, for example

    ['gzip -cdf foo.tar.gz', '|', 'tar -xf -']

Since this will lead to issues as described above.

=item IO Redirect

Currently it is too complicated to parse your command for IO
Redirections. For capturing STDOUT or STDERR there is a work around
however, since you can just inspect your buffers for the contents.

=back

=head1 See Also

C<IPC::Run>, C<IPC::Open3>

=head1 ACKNOWLEDGEMENTS

Thanks to James Mastros and Martijn van der Streek for their
help in getting IPC::Open3 to behave nicely.

=head1 BUG REPORTS

Please report bugs or other issues to E<lt>[e-mail]<gt>.

=head1 AUTHOR

This module by Jos Boumans E<lt>[e-mail]<gt>.

=head1 COPYRIGHT

This library is free software; you may redistribute and/or modify it 
under the same terms as Perl itself.

=cut