Implement URI::smb

Rework to enable updating user and authdomain

disable fail-fast to troubleshoot builds

Exclude Strawberry v5.16

URI::Heuristic recognizing UNC paths as SMB

Add smb section to README

Formal changes

Author: I. M. Bur

.github/workflows/dzil-build-and-test.yml

@@ -68,17 +68,19 @@ jobs:
           - "5.32"
           - "5.34"
           - "5.36"
+          - "5.38"
+          - "5.40"
         exclude:
           - { os: windows-latest, distribution: default }
           - { os: macos-latest,   distribution: strawberry }
           - { os: ubuntu-latest,  distribution: strawberry }
-          - { distribution: strawberry, perl-version: "5.8" }
           - { distribution: strawberry, perl-version: "5.10" }
           - { distribution: strawberry, perl-version: "5.12" }
           - { distribution: strawberry, perl-version: "5.14" }
           - { distribution: strawberry, perl-version: "5.16" }
           - { distribution: strawberry, perl-version: "5.34" }
           - { distribution: strawberry, perl-version: "5.36" }
+          - { distribution: strawberry, perl-version: "5.8" }
     runs-on: ${{ matrix.os }}
     name:  on ${{ matrix.os }} perl ${{ matrix.perl-version }}
     steps:

Changes

@@ -1,6 +1,7 @@
 Revision history for URI
 
 {{$NEXT}}
+    - Add smb scheme (buralien)
 
 5.31      2024-11-06 03:38:29Z
     - Re-releasing with corrected module permissions. No changes since 5.31

dist.ini

@@ -157,6 +157,8 @@ stopword = TOTP
 stopword = HOTP
 stopword = OTP
 stopword = cryptographic
+stopword = authdomain
+stopword = sharename
 
 ;;; pre-release actions
 

lib/URI.pm

@@ -1153,6 +1153,13 @@ I<sip> parameters: $uri->params_form and $uri->params.
 See I<sip> scheme.  Its syntax is the same as sip, but the default
 port is different.
 
+=item B<smb>:
+
+C<URI> objects belonging to the smb scheme support the common,
+generic and server methods. In addition, they provide methods to
+access the userinfo sub-components ($uri->user and $uri->password)
+as well as $uri->authdomain and $uri->sharename methods.
+
 =item B<snews>:
 
 See I<news> scheme.  Its syntax is the same as news, but the default

lib/URI/Heuristic.pm

@@ -158,6 +158,11 @@ sub uf_uristr ($)
     } elsif (/^(ftp|gopher|news|wais|https|http)[a-z0-9-]*(?:\.|$)/i) {
 	$_ = lc($1) . "://$_";
 
+    } elsif (
+		m,^//, || m,^[\\][\\],) # UNC-like file name
+    {
+		s{[\\]}{/}g;
+		$_ = "smb:$_";
     } elsif ($^O ne "MacOS" && 
 	    (m,^/,      ||          # absolute file name
 	     m,^\.\.?/, ||          # relative file name

lib/URI/smb.pm

@@ -0,0 +1,101 @@
+package URI::smb;
+
+use strict;
+use warnings;
+
+use parent 'URI::_login';
+
+our $VERSION = '5.32';
+
+sub default_port { 445 }
+
+sub user {
+    my $self = shift;
+    my $new = shift;
+    my ($user, $authdomain) = _parse_user($self->SUPER::user());
+    if ($new) {
+        $self->SUPER::user($authdomain ? "$authdomain;$new" : $new);
+        $user = $new;
+    }
+    return $user;
+}
+
+sub authdomain {
+    my $self = shift;
+    my $new = shift;
+    my ($user, $authdomain) = _parse_user($self->SUPER::user());
+
+    # it must not be possible to set authdomain without user
+    if ($user && $new) {
+        $self->SUPER::user("$new;$user");
+        $authdomain = $new;
+    }
+    return $authdomain;
+}
+
+sub sharename {
+    return (shift->path_segments)[1];
+}
+
+sub _parse_user {
+    my $input = shift or return;
+    my ($authdomain, $user) = split ';', $input, 2; 
+    return $user ? ($user, $authdomain) : $authdomain;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+URI::smb - Samba/CIFS URI scheme
+
+=head1 SYNOPSIS
+
+    my $uri = URI->new('smb://authdomain;user:password@server/share/path');
+
+=head1 DESCRIPTION
+
+This module implements the (unofficial) C<smb:> URI scheme described in L<http://www.ubiqx.org/cifs/Appendix-D.html>.
+
+=head1 SUBROUTINES/METHODS
+
+=head2 default_port
+
+The default port for accessing Samba/Windows File Servers is 445
+
+=head2 user
+
+Get or set the user part of the URI (without the authdomain)
+
+=head2 authdomain
+
+Get or set the authentication authdomain part of the URI. This value is only available if the user is already set.
+
+=head2 sharename
+
+Helper method to get the share name from path
+
+=head1 DEPENDENCIES
+
+None
+
+=head1 BUGS AND LIMITATIONS
+
+See L<URI|URI#BUGS>
+
+=head1 SEE ALSO
+
+L<http://www.ubiqx.org/cifs/Appendix-D.html>
+
+=head1 AUTHOR
+
+I. M. Bur <[email protected]>
+
+=head1 LICENSE AND COPYRIGHT
+
+This program is free software; you can redistribute it and/or modify it
+under the terms of either: the GNU General Public License as published
+by the Free Software Foundation; or the Artistic License.
+
+See L<http://dev.perl.org/licenses/> for more information.

t/heuristic.t

@@ -13,7 +13,7 @@ BEGIN {
     };
 }
 
-use Test::More tests => 26;
+use Test::More tests => 28;
 
 use URI::Heuristic qw( uf_url uf_urlstr );
 if (shift) {
@@ -102,6 +102,10 @@ is(uf_urlstr("perl"), "http://www.perl.org");
 
     is(uf_urlstr("123.3.3.3:21/foo"), "ftp://123.3.3.3:21/foo");
 
+    is(uf_urlstr("//server/share/dir"), "smb://server/share/dir");
+    
+    is(uf_urlstr(qq(\\\\server\\share\\dir)), "smb://server/share/dir");
+
     is(uf_url("FTP.example.com")->scheme, "ftp");
 
     is(uf_url("ftp2.example.com")->scheme, "ftp");

t/smb.t

@@ -0,0 +1,35 @@
+use strict;
+use warnings;
+
+use Test::More tests => 15;
+
+use URI ();
+my $uri;
+
+$uri = URI->new('smb://domain;user:password@server/share$/path');
+
+is($uri->scheme, 'smb');
+is($uri->authdomain, 'domain');
+is($uri->user, 'user');
+is($uri->password, 'password');
+is($uri->host, 'server');
+is($uri->port, 445);
+is($uri->sharename, 'share$');
+is($uri->path, '/share$/path');
+
+$uri->userinfo(undef);
+
+is($uri->authdomain, undef);
+is($uri->user, undef);
+is($uri->password, undef);
+is($uri->as_string, 'smb://server/share$/path');
+
+# test that domain without user is not allowed
+$uri->authdomain('DOMAIN');
+is($uri->as_string, 'smb://server/share$/path');
+
+$uri->user('Administrator');
+is($uri->as_string, 'smb://Administrator@server/share$/path');
+
+$uri->authdomain('DOMAIN');
+is($uri->as_string, 'smb://DOMAIN;Administrator@server/share$/path');