No subject


Tue Dec 2 03:01:20 GMT 2003


mounts are perfectly happy, but every little thing that can be done to
"perfectly" emulate a win32 share can only be a "Good Thing"(tm)

I'm using the Win32::File module that comes with ActivePerl 5.6.0.623 to
test it, I've got a sample program that shows what I'm running into if
anyone is interested.  I'd do the truly noble Open Source thing and find
it myself/submit a patch, but I'm interested to know if this has already
been reported/fixed in 2.0.7 and above (and frankly, I wouldn't know where
to begin..  =)

So, to the point, has this been fixed already??  Is it "supposed" to work
this way, and if so, why??

Thank you for your time,

--
Nicolas Simonds
nic at tricord.com 

-----(SAMPLE CODE BELOW)-----

#  :set ts=4 in vi for optimum readability...

use strict(vars,subs);

## Configgerable options..  Override with @ARGV if you want..

my $uncname    = shift || '\\\\someserver\\someshare';
my $domain     = shift || 'domain';
my $user       = shift || 'foouser';
my $password   = shift || 'foopass';
my %nethash;

##  FORMAT:
##  keys should be \d\d_subroutinename..  They are run in ascending order..
##  values should be [ 'statustext', @subroutine_options ]
my %testlist = (
'10_ValidateUser' => [ 'Validating user information against domain controller', $domain, $user, $password ],
'20_ConnectTest' => [ "Testing connection to $uncname", $uncname, $user, $password ],
'25_ConnectVolume' => [ "Connecting to $uncname", $uncname, $user, $password, \%nethash ],
'50_Attributes' => [ 'Testing RHSA, etc. bits' ],
'99_DisconnectVolume' => [ 'Disconnecting network volume', \%nethash ],
);

#  I'm sorry about this..  But it seems to work zero-maintenance..
#  Anyhow, when you write a subroutine, make sure it returns a result code
#  (Perl-style, meaning 0 == fail, not success) and an error
#  message, and throttle all output from inside..
foreach (sort keys %testlist) {
my ($msg, $rc, $errmsg);
$msg = substr(shift @{ $testlist{$_} }, 0, 70);
print $msg, ' ' x (70 - length($msg));
($rc, $errmsg) = substr($_, 3)->(@{$testlist{$_}});
if    ($rc < 0) { print "[SKIP]\n[$errmsg]\n" }
elsif ($rc)     { print "[ OK ]\n" }
else {
print "[FAIL]\n[$errmsg]\n";
DisconnectVolume(\%nethash);
exit 1;
}
}
exit;  ## END main program.  It's all subroutines from here...

#---------------------------------------------------------------------------

#
# SUBROUTINE ValidateUser
#
# usage: $rc = ValidateUser($domain, $user, $password);
#        @rc = ValidateUser($domain, $user, $password);
#
# in scalar context, returns 1 on success, 0 on failure
# in list context, also returns an error message
sub ValidateUser {
use Win32::AuthenticateUser;

my $domain = shift || return 0;
my $user   = shift || return 0;
my $passwd = shift || return 0;

# I love coderefs..
my $genstring = sub {
my $string = '';
my @chrset=('a'..'z', 'A'..'Z', '0'..'9', '.', '/');
my $length = int(rand(10) + 0.5);
for (my $x = 0; $x < $length; $x++) {
$string .= $chrset[int(rand(scalar(@chrset)))];
}
        return $string;
};

# Make sure the information given was good..
unless (AuthenticateUser($domain, $user, $passwd)) {
return (wantarray) ? (0, "user ${domain}:${user} Authentication FAILED") : 0;
}

# Make sure it's actually checking the password (feed it junk)..
$passwd = $genstring->();
if (AuthenticateUser($domain, $user, $passwd)) {
return (wantarray) ? (0, "user ${domain}:${user} Authentication SUCCEEDED, expected FAIL") : 0;
}

# Redundant check - feed it all junk..
$domain = $genstring->();
$user = $genstring->();
if (AuthenticateUser($domain, $user, $passwd)) {
return (wantarray) ? (0, "user ${domain}:${user} Authentication SUCCEEDED, expected FAIL") : 0;
}

return 1;
}

#---------------------------------------------------------------------------

# SUBROUTINE ConnectTest
#
# usage:
# $rc = ConnectTest($uncname, $user, $pass);
# @rc = ConnectTest($uncname, $user, $pass);
#
# This test is simply a stub to test ConnectVolume and DisconnectVolume, before
# committing to using them for the duration of the program..
#
# in scalar context, returns 1 on success, 0 on failure
# in list context, also returns an error message
#
sub ConnectTest {
my (@rc, %hash);
@rc = ConnectVolume(@_, \%hash);
(return (wantarray) ? @rc : $rc[0]) unless $rc[0];
@rc = DisconnectVolume(\%hash);
return (wantarray) ? @rc : $rc[0];
} # END ConnectTest

#---------------------------------------------------------------------------

# SUBROUTINE ConnectVolume
#
# usage:
# $rc = ConnectVolume($uncname, $user, $pass, \%hashref);
# @rc = ConnectVolume($uncname, $user, $pass, \%hashref);
#
# in scalar context, returns 1 on success, 0 on failure
# in list context, also returns an error message
#
sub ConnectVolume {
use Win32;
use Win32::NetResource qw(:DEFAULT NetShareGetInfo AddConnection );
my $uncname    = shift || return 0;
my $username   = shift || return 0;
my $password   = shift || return 0;
my $hashref    = shift || return 0; 
# split() kept returning blank fields..  Ho hum..
my ($servername, $sharename) = ($uncname =~ m/^\\\\(.*?)\\(.*?)(?:\\|$)/);

$hashref->{'RemoteName'} = $uncname;
$hashref->{'LocalName'} = Win32::GetNextAvailDrive() ||
return (wantarray) ? (0, 'No available drive letters for mapping') : 0;

AddConnection($hashref, $password, $username, 0) || return (wantarray) ? (0, "Error connecting to $hashref->{'RemoteName'}: $^E") : 0;
#foreach (sort keys %{ $hashref }) { print "$_ -> $hashref->{$_}\n" }

return 1;
} # END ConnectVolume

#---------------------------------------------------------------------------

# SUBROUTINE DisconnectVolume
#
# usage:
# $rc = DisconnectVolume(\%hashref);
# @rc = DisconnectVolume(\%hashref);
#
# in scalar context, returns 1 on success, 0 on failure
# in list context, also returns an error message
#
sub DisconnectVolume {
use Win32;
use Win32::NetResource qw(:DEFAULT CancelConnection );
my $hashref    = shift || return 0; 

#foreach (sort keys %{ $hashref }) { print "$_ -> $hashref->{$_}\n" }
CancelConnection($hashref->{'LocalName'}, 1, 1) || return (wantarray) ? (0, "Error disconnecting $hashref->{'RemoteName'}: $^E") : 0;

return 1;
} # END DisconnectVolume

#---------------------------------------------------------------------------

# SUBROUTINE Attributes
#
# usage:
# $rc = Attributes();
# @rc = Attributes();
#
# in scalar context, returns 1 on success, 0 on failure
# in list context, also returns an error message
#
sub Attributes {
# 0x0001 READONLY
# 0x0002 HIDDEN
# 0x0004 SYSTEM
# 0x0010 DIRECTORY  <-- Setting this does NOT turn a file into a dir, ignore
# 0x0020 ARCHIVE
# 0x0080 NORMAL     <-- Setting this negates everything else, ignore
# 0x0100 TEMPORARY
# 0x0800 COMPRESSED <-- NTFS only.  Do not test until we're 100% compatible
# 0x1000 OFFLINE    <-- kludge option for special win2k opplications only.
    #                       Documentation says "do not touch"
# 
# Marked bits above silently fail when setting, how nice.  Skip them
# explicitly with exclusion mask: 0x1ED8

my $getmask = sub {
use Win32::File qw( :DEFAULT SetAttributes GetAttributes );
##
##
##  SUSPECTED BUG -- WIN32 SHARES RETURN "NORMAL" BITS, SAMBA RETURNS
##  NOTHING..  COMMENT OUT TOP LINE AND UNCOMMENT BOTTOM LINE TO SEE
##  WHAT I MEAN..
##
##
my $val = shift || return NORMAL();
#my $val = shift || return 0;
my $retval = 0;
($val & 0x0001) and $retval |= READONLY();
($val & 0x0002) and $retval |= HIDDEN();
($val & 0x0004) and $retval |= SYSTEM();
($val & 0x0010) and $retval |= DIRECTORY(); # This should never get hit
($val & 0x0020) and $retval |= ARCHIVE();
($val & 0x0080) and $retval |= NORMAL();    # This should never get hit
($val & 0x0100) and $retval |= TEMPORARY();
($val & 0x0800) and $retval |= COMPRESSED();
($val & 0x1000) and $retval |= OFFLINE();
return $retval;
};

my $file = "$nethash{'LocalName'}\\tmpfile.$$";
open(TMP, "> $file") || return (wantarray) ? (0, "open failed: $!"): 0;
close(TMP);
SetAttributes($file, NORMAL()) || return (wantarray) ? (0, "initial SetAttributes failed: $^E") : 0;
sleep 1;

for (my $i = 0; $i < 0x2000; $i++) {
my ($value, $value2);
next if ($i & 0x1ED8);
$value = $getmask->($i);
SetAttributes($file, $value) || return (wantarray) ? (0, "Iteration $i($file) SetAttributes failed: $^E") : 0;
GetAttributes($file, $value2) || return (wantarray) ? (0, "Iteration $i($file) GetAttributes failed: $^E") : 0;
$value == $value2 || return (wantarray) ? (0, "Iteration $i($file) failed: expected $value got $value2") : 0;
SetAttributes($file, NORMAL()) || return (wantarray) ? (0, "Iteration $i($file) SetAttributes failed: $^E") : 0;
}

unlink($file);
return 1;
} # END Attributes

#---------------------------------------------------------------------------





More information about the samba-technical mailing list