view release on metacpan or  search on metacpan

bin/dave  view on Meta::CPAN

my $gdc = HTTP::DAV->new(-useragent=>$useragent);
HTTP::DAV::DebugLevel($debug);

## Setup the help system 
my $help = Pod2HelpParser->new();
$help->parse_from_filehandle(\*DATA);

## Setup the valid commands and synonyms
my @valid_commands = qw( cd cat copy delete edit get help
   lcd lls ls lpwd lock mkcol move open options propfind put pwd
   quit set sh showlocks steal unlock unset );

my %command_synonyms = qw(
   !     sh
   ?     help
   q     quit
   bye   quit
   h     help
   dir   ls
   mkdir mkcol
   rmdir delete
   rm    delete
   cp    copy
   mv    move
);

# Make a full populated hash from those given above.
# %commands = (
#  quit => quit,
#  q    => quit,
#  help => help,
#  ?    => help,
my %commands;
foreach my $command (@valid_commands) {
   $commands{$command} = $command;
}

# Invert the command_synonyms for easy lookup.
foreach my $synonym (keys %command_synonyms ) {
   $commands{$synonym} = $command_synonyms{$synonym};
}

###########################################################################
# MAIN

pod2usage(-verbose => 1)  if ($opt_h);
pod2usage(-verbose => 2)  if ($opt_man);

# Barf if more than one URL
if (@ARGV > 1) {
   pod2usage( -message => "$0: You must only specify one URL.\n")
}

print $OUT <<END;

dave -- DAV Explorer (v$VERSION)
Try "help", or "open http://host.com/dav_enabled_dir/"

END

# Put the credentials into HTTP::DAV for $url
my $url=shift @ARGV;
if ($user && $url) {
   $gdc->credentials( -user=>$user, -pass=>$pass, -url=>$url );
}
&command_open($url) if ($url );

######################################################################
# WHILE dave> command
my $line;
while ( defined ($line = $term->readline($prompt)) ) {

   # Hack. Put a space between the ! shellout command and the next arg
   $line =~ s/^([!])/$1 /g;

   # Parse the user's typed command and return a parsed list of words.
   my @args = &shellwords($line); 

   # Remove empty elements from the list
   @args = grep( ! /^\s*$/,@args);

   # If the user has entered nothing then back to while 
   # loop and throw another command prompt.
   next if ( ! @args );

   # Get the first argument. It should be the command.
   my $command = shift @args;

   # Check the validity of the command in our lookup.
   if ( &is_valid_command($command) ) {

      # This is so we can do the ref'ed function call 
      no strict 'refs'; 

      $command = &get_command($command);
     
      print $OUT "Valid Command: \"$command\"\n" if $HTTP::DAV::DEBUG>2;

      # Call the command. e.g. &command_put(@args)
      my $function_name = "command_" . $command;
      my $return_code = &$function_name(@args);

   } else {
      print $OUT "Unrecognised command. Try 'help or h' for a list of commands.\n";
   }
}

######################################################################
# Command implementations

# This is a simple "print message" (pm) routine. 
# Keeps things neat.
sub pm { print $OUT "** $_[0] **\n"; }

sub command_cd     { $gdc->cwd    (@_); pm($gdc->message()) }
sub command_copy   { $gdc->copy   (@_); pm($gdc->message()) }

sub command_delete { 
   $gdc->delete(-url=> $_[0], -callback=>\&cb);
   pm($gdc->message());
}

sub command_mkcol  { $gdc->mkcol  (@_); pm($gdc->message()) }
sub command_move   { $gdc->move   (@_); pm($gdc->message()) }

bin/dave  view on Meta::CPAN

         print "\n" if ($in_transfer);
         print "  $mesg (success)\n";
         $in_transfer=0;
      }
      if ($status == 0) {
         print "**$mesg\n";
         $in_transfer=0;
      }
      if ($status == -1) {
         if (!$in_transfer++) {
            print "  Transferring $url ($length bytes):\n";
         }
         my $width = 60;
         if ($length>0) {
            my $num = int($so_far/$length * $width);
            my $space = $width-$num;
            print "  [" . "#"x$num . " "x$space . "]";
         }
         print " $so_far bytes\r";
      }
   }
}

###########################################################################
sub is_valid_command {
   my ($command) = @_;
   $command = lc($command);
   return 1 if defined $commands{$command};
}

sub get_command {
   my ($command) = @_;
   $command = lc($command);
   return $commands{$command};
}

BEGIN {
# We make our own specialization of HTTP::DAV::UserAgent (which in turn is already a specialisation of LWP::UserAgent).
# This user agent is able to:
#  - interact with the user on the command line to get user/pass's
#  - allow the user to try 3 times before failing.
{
    package DAVE::UserAgent;
    use vars qw(@ISA);
    @ISA = qw(HTTP::DAV::UserAgent);

    sub new {
       my $self = HTTP::DAV::UserAgent::new(@_);
       #$self->agent("DAVE/v$VERSION");
       $self->{_failed_logins} = ();
       return $self;
    }

    sub request {
       my($self) = shift;
       my $resp = $self->SUPER::request(@_);

       # Only if we did not get a 401 back from the server
       # do we go and 
       # commit the user's details to memory.
       $self->_commit_credentials() if ($resp->code() != 401);
       return $resp;
    }

    sub _set_credentials {shift->{_temp_credentials} = \@_; }
    sub _commit_credentials {
       my ($self)=@_;
       if (defined $self->{_temp_credentials} ) {
          $self->credentials(@{$self->{_temp_credentials}});
          $self->{_temp_credentials} = undef;
       }
    }

    sub get_basic_credentials {
       my($self, $realm, $url) = @_;
       my $userpass;

       # First, try to get the details from our memory.
       my @mem_userpass = $self->SUPER::get_basic_credentials($realm,$url);
       return @mem_userpass if @mem_userpass;

       if (-t) {

          my $netloc = $url->host_port;
          if ($self->{_failed_logins}->{$realm . $netloc}++ > 3) {
             return (undef,undef) 
          }

          print "\nEnter username for $realm at $netloc: ";
          my $user = <STDIN>;
          chomp($user);
          return (undef, undef) unless length $user;
          print "Password: ";
          system("stty -echo");
          my $password = <STDIN>;
          system("stty echo");
          print "\n";  # because we disabled echo
          chomp($password);

          $self->_set_credentials($netloc, $realm,$user,$password);
          #print "Returning $user, $password\n";
          return ($user, $password);
      } else {
          return (undef, undef)
      }
   }
}

######################################################################
# Setup our help system with this nifty Pod::Parser from the 
# Pod at the end of this script.
#
{
   package Pod2HelpParser;
   
   use vars qw(@ISA);
   use Pod::Parser;
   @ISA = qw(Pod::Parser);
   
   ######
   # Pod2HelpParser - public help access methods.
   # 
   # get_help() will return from the pod any items 
   # that start with $command as help
   #
   # For instance:
   #    my($sect,$title,$terse,$long) = $parser->get_help("open");
   sub get_help { 
      my ($self,$command) = @_;
      foreach my $sect (keys %{$self->{_help_text}} ) {
         if ( $sect =~ /^$command\b/i ) {
            my $title       = $self->{_title}     {$sect} ||"";
            my $first_line  = $self->{_first_line}{$sect} ||"";
            my $help_text   = $self->{_help_text} {$sect} ||"";
            $help_text=~ s/\n*$//gs;
            return ($sect,$title,$first_line,$help_text);
         }
      }
      return ();
   }

   sub get_help_list {
      my ($self) = @_;
      my @return;
      foreach my $sect (keys %{$self->{_help_text}} ) {
         next if $sect eq "OTHER";
         push (@return,$sect);
      }
      return @return;
   }
   
   ######
   # INIT
   # These methods are all overriden from Pod::Parser.
   # They are effectively call-backs to handle pod.
   # Specifically, we're building a hash to provide convenient
   # access to the pod data as help information.
   sub command { 
       my ($parser, $command, $paragraph, $line_num) = @_;
       my $title = $parser->interpolate($paragraph, $line_num);