view release on metacpan or  search on metacpan

lib/App/Smbxfer.pm  view on Meta::CPAN

#! /usr/bin/perl

package App::Smbxfer;
our $VERSION = 0.01;

use strict;
use warnings;
use Carp;

use Exporter;
use Getopt::Long;
use IO::Prompt;
use Filesys::SmbClient;

# Exports...
use base qw( Exporter );
our @EXPORT_OK = qw(
    credentials             do_smb_transfer          parse_smb_spec
    create_smb_dir_path     create_local_dir_path    smb_element_type
    smb_upload              smb_download
);

__PACKAGE__->run unless caller;

#######

sub usage {
    qq{
USAGE
    Smbxfer <options> //<server>/<share>[/<path>[/<filename>]] <local-name>
    Smbxfer <options> <local-name> //<server>/<share>[/<path>/<filename>]

}
}

#######

sub options {
    qq{
OPTIONS
    Usage information:
    --usage|help

    Command-line options:
    --options

    Name of file containing credentials (standard smb credentials file):
    --cred <credentials-filename>
    
    Transfer directory <local-name>:
    --recursive

    Create parent directories:
    --parents

}
}

#######

sub run {
    # Process command-line options...
    my ($cred, $recursive, $create_parents, $usage, $options);
    my $options_ok = GetOptions(
        'cred=s'        => \$cred,
        'recursive'     => \$recursive,
        'parents'       => \$create_parents,
        'usage|help'    => \$usage,
        'options'       => \$options,
    );
    die usage unless $options_ok;

    ( defined $usage ) && die usage;
    ( defined $options ) && die options;
    
    my ( $source, $dest ) = @ARGV;
    die usage unless defined $source && defined $dest;
     
    # Ensure that exactly one of source/dest is in "SMB path spec" format...
    ($dest =~ m|^//|) xor ($source =~ m|^//|) or die usage;
    
    # Get access credentials for SMB connection...
    my ($username, $password, $domain) = credentials($cred);
    
    # Prepare SMB connection object...
    my $smb = Filesys::SmbClient->new(
        username => $username, password => $password, workgroup => $domain
    );

    # Determine if source is local (not in "SMB path spec" format)...
    my $source_is_local = ($source !~ m|^//|);

    my ($local_path, $remote_smb_path_spec) = validated_paths(
        SMB => $smb,
        SOURCE => $source,
        DEST => $dest,
        SOURCE_IS_LOCAL => $source_is_local
    );
    
    # Initiate transfer...
    do_smb_transfer(
        SMB_OBJECT =>        $smb,
        LOCAL_PATH =>        $local_path,
        SMB_PATH_SPEC =>     $remote_smb_path_spec,
        SOURCE_IS_LOCAL =>   $source_is_local,
        RECURSIVE =>         $recursive,
        CREATE_PARENTS =>    $create_parents
    );
}

#########################

sub credentials {
    my ($credentials_filename) = @_;

    my ($username, $password, $domain);

    if ($credentials_filename) {
        # Read access credentials from file formatted using standard smbmount
        # syntax...
        open( my $credentials, '<', "$credentials_filename" )
            or croak "cannot open credentials file: $!";
    
        my @lines;
        while( <$credentials> ){
            my ($value) = (m/.*=\s+?(.*)$/);
            push @lines, $value;
        }
        close $credentials;
        ($username, $password, $domain) = @lines;
    }
    else {
        # Getting credentials interactively...
        $username = prompt( "username? " );
        $password = prompt( "password? ", -e => '*' );
        $domain =   prompt( "domain? " );
    }

    return $username, $password, $domain;
}

#########################

sub validated_paths {
    my %param = @_;

    my $smb =               $param{SMB}     or croak "SMB object required";
    my $source =            $param{SOURCE};
    my $dest =              $param{DEST};
    my $source_is_local =   $param{SOURCE_IS_LOCAL};

    defined $source          or croak "Source path required";
    defined $dest            or croak "Destination path required";
    defined $source_is_local or croak "SOURCE_IS_LOCAL param required";

    # Ensure that exactly one of source/dest is in "SMB path spec" format...
    ($dest =~ m|^//|) xor ($source =~ m|^//|)
        or croak 'source OR destination must be in "SMB path spec" format';
    
    my ($local_path, $remote_smb_path_spec) = ($source, $dest);
    ($local_path, $remote_smb_path_spec) = ($dest, $source) unless $source_is_local;

    # Normalize form of local and remote paths...
    $local_path =~ s|//|/|g;
    $local_path =~ s|/$||;
    $remote_smb_path_spec =~ s|^/+||;  # temporarily remove valid leading '//'
    $remote_smb_path_spec =~ s|//|/|g;
    $remote_smb_path_spec =~ s|/$||;   # no trailing slash
    $remote_smb_path_spec = 'smb://' . $remote_smb_path_spec;

    # Find type of remote element...
    my $remote_element_type = smb_element_type( $smb, $remote_smb_path_spec )
        or croak "Error: SMB specification $remote_smb_path_spec not found";

    # Check types of source and destination...
    my ($source_is_dir, $dest_is_dir_or_nonexistent);
    if( $source_is_local ) {
        croak "Error: local source $source is not a file or a directory"
            unless( -f $source or -d $source );
        $source_is_dir = -d $source;
        $dest_is_dir_or_nonexistent = 1 unless defined $remote_element_type;
        # Consider file shares to be directories for purposes of file transfer...
        $dest_is_dir_or_nonexistent = 1 if $remote_element_type == SMBC_DIR or $remote_element_type == SMBC_FILE_SHARE;
    }
    else {
        croak "Error: SMB source $source is not a file or a directory"
            unless( $remote_element_type == SMBC_FILE or $remote_element_type == SMBC_DIR );
        $source_is_dir = ( $remote_element_type == SMBC_DIR );
        $dest_is_dir_or_nonexistent = (not -e $dest or -d $dest);
    }

    # If source is a dir, any existing dest must also be a dir...
    croak "Error: when transferring a directory source, any existing destination must also be a directory"