File Coverage

blib/lib/App/Smbxfer.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

#! /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  ///[/[/]]
    Smbxfer   ///[//]

}
}

#######

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

    Command-line options:
    --options

    Name of file containing credentials (standard smb credentials file):
    --cred

    Transfer directory :
    --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"
        if( $source_is_dir and not $dest_is_dir_or_nonexistent );

    return $local_path, $remote_smb_path_spec;
}

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

sub do_smb_transfer {
    my %param = @_;

    my $smb =                                 $param{SMB_OBJECT}        or croak "SMB object required";
    my $local_path =                          $param{LOCAL_PATH}        or croak "local path required";
    my $smb_path_spec =                       $param{SMB_PATH_SPEC}     or croak "remote SMB path specification required";
    my $source_is_local =                     $param{SOURCE_IS_LOCAL};
    my $recursive =                           $param{RECURSIVE};
    my $create_parents =                      $param{CREATE_PARENTS};

    # Create leading directories of destination path if requested...
    if( $create_parents ) {
        my ($smb_parent_path) = ( parse_smb_spec( $smb_path_spec ) )[2];

        if( $source_is_local ) {
            # Create remote SMB path to hold local source...
            my ($local_path_parent_dirs) = ( $local_path =~ m|/?(.*)/[^/]+/?$| );

            my $element_type = smb_element_type( $smb, $smb_path_spec );
            unless( $element_type == SMBC_DIR or $element_type == SMBC_FILE_SHARE ) {
                die "Error: destination must be a directory with --parents option.";
            }
            create_smb_dir_path( $smb, $smb_path_spec, $local_path_parent_dirs );

            # postfix destination path with parent dirs we just created from source...
            $smb_path_spec .= '/' . $local_path_parent_dirs;
        }
        else {
            # Create local path to hold remote SMB source...
            unless( -d $local_path ) {
                die "Error: destination must be a directory with --parents option.";
            }
            create_local_dir_path( $local_path, $smb_parent_path );

            # postfix destination path with parent dirs we just created from source...
            $local_path .= '/' . $smb_parent_path;
        }
    }

    my $rc = 0;
    if( $source_is_local ) {
        # Transfer: local -> remote...
        $rc = smb_upload(
            SMB_OBJ => $smb,
            SOURCE => $local_path,
            SMB_PATH_SPEC => $smb_path_spec,
            RECURSIVE => $recursive
        );
    }
    else {
        # Transfer: remote -> local...
        $rc = smb_download(
            SMB_OBJ => $smb,
            SMB_PATH_SPEC => $smb_path_spec,
            LOCAL_DEST_NAME => $local_path,
            RECURSIVE => $recursive
        );
    }

    return $rc;
}

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

sub parse_smb_spec {
    my ($path) = @_;

    my ($server, $share);
    ($server, $share, $path) =
        ($path =~ m|
            //([\w\.]+)        # //server
            /(\w+)             #         /share
            /?(.+)?            #               /path/to/something
        |x);

    # Path spec is invalid...
    return unless $server && $share;

    my ($share_spec, $parent_path, $path_spec, $parent_path_spec, $basename);

    $share_spec = "smb://$server/$share/";
    $path_spec = $share_spec;
    $parent_path_spec = $share_spec;

    if( defined $path ) {
        ($parent_path) = ( $path =~ m|(.*/)[^/]+/?$| );
        $path_spec .= $path;
        $parent_path_spec .= $parent_path if $parent_path;
        ($basename) = ($path =~ m|([^/]*)$| );
    }

    return $server, $share, $parent_path, $path,
           $share_spec, $path_spec, $parent_path_spec,
           $basename;
}


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

sub create_smb_dir_path {
    my ( $smb, $smb_path_spec_prefix, $path_to_create ) = @_;

    my ($root, $remaining_path) =
        ($path_to_create =~ m|
            ^/?         # optional leading '/'
            ([^/]+?)    # 1st capture: anything but dir separators
            (/.*)?      # 2nd capture (optional): separator followed by dir names with separators
            /?$         # optional trailing '/'
        |x);

    if( $root ) {
        $smb->mkdir( $smb_path_spec_prefix . '/' . $root, '0666' )
            or croak "SMB error: cannot mkdir $smb_path_spec_prefix/$root: $!";
    }
    else {
        # We were called without a valid path to create...
        return;
    }

    if( $remaining_path ) {
        create_smb_dir_path( $smb, $smb_path_spec_prefix . '/' . $root, $remaining_path );
    }

    return 1;
}

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

sub create_local_dir_path {
    my ( $local_prefix, $path_to_create ) = @_;

    my ($root, $remaining_path) =
        ($path_to_create =~ m|
            ^/?         # optional leading '/'
            ([^/]+?)    # 1st capture: anything but dir separators
            (/.*)?      # 2nd capture (optional): separator followed by dir names with separators
            /?$         # optional trailing '/'
        |x);

    if( $root ) {
        mkdir( $local_prefix . '/' . $root ) or croak "cannot mkdir $root: $!";
    }
    else {
        # We were called without a valid path to create...
        return;
    }

    if( $remaining_path ) {
        create_local_dir_path( $local_prefix . '/' . $root, $remaining_path );
    }

    return 1;
}

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

sub smb_element_type {
    my ($smb, $smb_path_spec) = @_;

    my ($share_name, $smb_parent_path, $smb_path, $smb_share_spec,
    $smb_basename) = ( parse_smb_spec( $smb_path_spec ) )[1,2,3,4,7];

    my $base_type;
    if( $smb_path ) {
        if( $smb_basename ) {
            # Look in parent directory for base of path and find type of base
            my $parent = $smb_share_spec;
            $parent .= $smb_parent_path if $smb_parent_path;
            my $smb_fd = $smb->opendir( $parent )
                or croak "SMB error: cannot opendir: $!";

            while( my $share_root_item = $smb->readdir_struct( $smb_fd ) ) {
                if( lc $share_root_item->[1] eq lc $smb_basename ) {
                    $base_type = $share_root_item->[0];
                    last;
                }
            }
            $smb->closedir( $smb_fd );
        }
        else {
            # Path does not have multiple levels...
            # Open root dir of share and look for path...
            my $smb_fd = $smb->opendir( $smb_share_spec )
                or croak "SMB error: cannot opendir: $!";

             while( my $share_root_item = $smb->readdir_struct( $smb_fd ) ) {
                if( lc $share_root_item->[1] eq lc $smb_path ) {
                    $base_type = $share_root_item->[0];
                    last;
                }
            }
            $smb->closedir( $smb_fd );
        }
    }
    elsif( $smb_share_spec ) {
        # No path given; does the given SMB spec identify a file share?
        my ($server) = ( $smb_share_spec =~ m|smb://([^/]+)/| );
        my $smb_fd = $smb->opendir( "smb://$server/" )
            or croak "SMB error: cannot opendir: $!";
        while( my $share = $smb->readdir_struct( $smb_fd ) ) {
            if( lc $share->[1] eq lc $share_name ) {
                $base_type = $share->[0];
                last;
            }
        }
    }
    else {
        croak "SMB specification $smb_path_spec not found";
    }

    # Element not found...
    return if not defined $base_type;

    return $base_type;
}

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

sub smb_download {
    my %param = @_;

    my $smb =               $param{SMB_OBJ} or croak "Filesys::SmbClient object required for download";
    my $src_smb_path_spec = $param{SMB_PATH_SPEC} or croak "SMB path specification of source required to download";
    my $local_dest_name =   $param{LOCAL_DEST_NAME};
    my $recursive =         $param{RECURSIVE};

    my ($src_smb_path, $src_basename) =
        (parse_smb_spec( $src_smb_path_spec ))[3,7];

    my $elem_type = smb_element_type( $smb, $src_smb_path_spec );

    if( $elem_type == SMBC_DIR ) {
        # Download directory...
        unless( $recursive ) {
            print "Omitting directory $src_smb_path in non-recursive mode.\n";
            return;
        }
        else {
            # Create dir at destination...
            mkdir( $local_dest_name . '/' . $src_basename )
                or croak "cannot mkdir: $!";
        }

        my $smb_fd = $smb->opendir( $src_smb_path_spec )
            or croak "SMB error: cannot opendir: $!";

        while( my $smb_elem = $smb->readdir( $smb_fd ) ) {
            next if $smb_elem =~ /^\.{1,2}$/;     # skip . and ..
            smb_download(
                SMB_OBJ => $smb,
                SMB_PATH_SPEC => $src_smb_path_spec . '/' . $smb_elem,
                LOCAL_DEST_NAME => $local_dest_name . '/' . $src_basename,
                RECURSIVE => 1,
            );
        }
        $smb->closedir( $smb_fd );
    }
    elsif( $elem_type == SMBC_FILE ) {
        # Download file...

        # If destination is a dir then file goes inside it...
        $local_dest_name .= '/' . $src_basename if( -d $local_dest_name );

        open( my $localfile, '>', $local_dest_name )
            or croak "cannot open file: $!";

        my $smb_fd = $smb->open( $src_smb_path_spec )
            or croak "SMB error: cannot open: $!";

        while( my $buf = $smb->read( $smb_fd ) ) {
            print $localfile $buf;
        }

        $smb->close( $smb_fd );
        close( $localfile );
    }
    else {
        warn "$src_basename is not a directory or a file...ignoring.\n";
    }

    return 1;
}

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

sub smb_upload {
    my %param = @_;

    my $smb =               $param{SMB_OBJ}         or croak "Filesys::SmbClient object required for upload";
    my $local_src =         $param{SOURCE}          or croak "Name of local file or directory required for upload";
    my $smb_path_spec =     $param{SMB_PATH_SPEC}   or croak "SMB path specification of destination required for upload";
    my $recursive =         $param{RECURSIVE};

    my $elem_type = smb_element_type( $smb, $smb_path_spec );
    my ($src_basename) = ($local_src =~ m|([^/]*)$| );

    if( -d $local_src ) {
        # Upload directory...
        unless( $recursive ) {
            print "Omitting directory $local_src in non-recursive mode.\n";
            return;
        }
        else {
            # Create dir at destination...
            $smb->mkdir( $smb_path_spec . '/' .  $src_basename, '0666' )
                or croak "SMB error: cannot mkdir: $!";
        }

        opendir( my $local_dir, $local_src )
            or croak "cannot opendir: $!";

        while ( my $local_dir_elem = readdir( $local_dir ) ) {
            next if $local_dir_elem =~ /^\.{1,2}$/;     # skip . and ..

            smb_upload(
                SMB_OBJ => $smb,
                SOURCE => $local_src . '/' . $local_dir_elem,
                SMB_PATH_SPEC => $smb_path_spec . '/' . $src_basename,
                RECURSIVE => 1
            );
        }
        closedir( $local_dir );
    }
    elsif( -f $local_src ) {
        # Upload file...

        if( $elem_type == SMBC_FILE ) {
            # Destination is an existing file; remove file remotely...
            $smb->unlink( $smb_path_spec )
                or croak "SMB error: cannot unlink: $!";
        }
        elsif( $elem_type == SMBC_DIR ) {
            # Destination is an existing dir => file goes inside it...
            $smb_path_spec .= '/' . $src_basename;
        }

        open( my $sourcefile, '<', $local_src )
            or croak "cannot open file: $!";

        my $smb_fd = $smb->open('>' . $smb_path_spec, '0777')
            or croak "SMB error: cannot create file: $!";

        $smb->write( $smb_fd, $_ ) while( <$sourcefile> );

        $smb->close( $smb_fd );
        close( $sourcefile );
    }
    else {
        warn "$local_src is not a directory or a file...ignoring.\n";
    }

    return 1;
}

#########################
1;

__END__