File Coverage

blib/lib/URI/AnyService.pm

Criterion	Covered	Total	%
statement	68	71	95.7
branch	26	36	72.2
condition	4	8	50.0
subroutine	12	13	92.3
pod	2	2	100.0
total	112	130	86.1

package URI::AnyService;

# ABSTRACT: Simple /etc/services-driven URI objects
use version;
our $VERSION = 'v0.90.0'; # VERSION

use v5.16;
use strict;
use warnings;

### XXX: Is this abusing a private, undocumented class from an external module?  Yes.
###
### Are the risks of copying entire functions wholesale, and having those functions get changed from
### underneath us, far greater than the risk of this load-bearing and intertwined package name getting
### renamed?  Also yes.

use parent 'URI::_server';

use URI  ();
use Carp ();

#pod =head1 SYNOPSIS
#pod
#pod     use URI;
#pod     use URI::AnyService;
#pod
#pod     my $uri = URI->new('smtp://example.com');
#pod     say $uri->has_recognized_scheme;  # !!0
#pod     say $uri->port;                   # ''
#pod
#pod     my $uas = URI::AnyService->new('smtp://example.com');
#pod     say $uas->has_recognized_scheme;  # !!1
#pod     say $uas->port;                   # 25
#pod
#pod =head1 DESCRIPTION
#pod
#pod This module creates simple L-based objects for protocols that it doesn't yet have defined.
#pod It works just like L, except it just supports the L,
#pod and not anything scheme-specific.  In other words, most of the methods that C/C
#pod objects support.
#pod
#pod Port numbers are looked up from a C file.  If you don't have a C
#pod file, one will be provided for you, but there's no guarantee that it will be up-to-date or apply
#pod to your specific protocol.
#pod
#pod This allows you to use a URL like C without having to set a default port in
#pod the URL.
#pod
#pod =head1 GLOBAL VARIABLES
#pod
#pod =head2 %SERVICE_PORTS
#pod
#pod This is a hash of schemes/protocols to port numbers.  It is loaded from the C file,
#pod as soon as you C this module.
#pod
#pod Most of the time, you shouldn't mess with this.  But, if there is some new protocol that you need
#pod to add that happens to not exist in your C files, you can do so with:
#pod
#pod     $URI::AnyService::SERVICE_PORTS{'my-protocol'} = 1234;
#pod
#pod This variable is not exportable, so you need to use the full package syntax.
#pod
#pod =cut

our %SERVICE_PORTS;

#pod =head1 USE OPTIONS
#pod
#pod =head2 :InternalServicesData
#pod
#pod     use URI::AnyService ':InternalServicesData';
#pod
#pod This will force the internal services data to be loaded, even if the C file is
#pod available.  This is useful for testing, or if you know that the C files on your
#pod servers are not consistent.
#pod
#pod Please note that there are no guarantees that the internal data is up-to-date or accurate.  It's
#pod mostly used as a "last resort" fallback.
#pod
#pod =cut

my $found_services_in;
my $force_internal_services_data = 0;

sub _load_services {
    my $fh;
    # XXX: Windows support not tested.  This is just the usual location where it's expected to be.
    my $services_file = $^O eq 'MSWin32' ? 'C:\Windows\System32\drivers\etc\services' : '/etc/services';
    if (!$force_internal_services_data && -f -r $services_file) {
        open $fh, '<', $services_file or Carp::croak("Can't open /etc/services: $!");
        $found_services_in = $services_file;
    }
    else {
        $fh = \*DATA;
        $found_services_in = '';
    }

    while (my $line = <$fh>) {
        next if $line =~ /^#/;
        $line =~ s/#.*$//;
        next unless ($line // '') =~ /^$URI::scheme_re\s+/;

        my ($service, $port_proto, @other_services) = split /\s+/, $line;
        my ($port, $proto) = split m!/!, $port_proto;
        $SERVICE_PORTS{$service}        = $port;
        $SERVICE_PORTS{@other_services} = $port if @other_services;
    }
    close $fh;
}

sub import {
    my ($class, @opts) = @_;
    $force_internal_services_data = 1 if grep { $_ eq ':InternalServicesData' } @opts;
    _load_services();
}

#pod =head1 CONSTRUCTOR
#pod
#pod     URI::AnyService->new($str);
#pod     URI::AnyService->new($str, $scheme);
#pod
#pod This constructor is very similiar to L, including the
#pod somewhat-legacy two parameter form.  In most cases, you should just use the whole URL string.
#pod
#pod A scheme that was defined in the services file is required.
#pod
#pod =cut

# Less /o bugs, more modern usage, still using the URI scheme RE
my $scheme_re            = qr/^($URI::scheme_re):/;
my $scheme_re_sans_colon = qr/^($URI::scheme_re)/;

### XXX: Most of this code for `new` and `_scheme` were copied from URI, but irrelevant parts
### have been removed and optimized.

sub new {
    my ($class, $uri, $scheme) = @_;

    $uri = defined $uri ? "$uri" : "";   # stringify

    # Get rid of potential wrapping
    $uri =~ s/^<(?:URL:)?(.*)>$/$1/;
    $uri =~ s/^"(.*)"$/$1/;
    $uri =~ s/^\s+//;
    $uri =~ s/\s+$//;

    # We ARE the implementor class
    $scheme = $1 if $uri =~ s/$scheme_re//;
    Carp::croak("No scheme defined in URI: $uri")                   unless $scheme;
    Carp::croak("Scheme '$scheme' not found in $found_services_in") unless $SERVICE_PORTS{lc $scheme};

    # Find all funny characters and encode the bytes
    $uri = URI->_uric_escape($uri);
    $uri = "$scheme:$uri";
    my $self = bless \$uri, $class;
    $self;
}

sub _no_scheme_ok { 0 }

sub _scheme {
    my $self = shift;

    unless (@_) {
        return undef unless $$self =~ $scheme_re;
        return $1;
    }

    # URI supports this weird setting of the scheme to create a new URI object, which is fine,
    # but it should call us, not URI->new.
    my $old;
    my $new = shift;
    if (defined $new && length $new) {
        # Error checks before we mutate $self
        Carp::croak("Bad scheme '$new'") unless $new =~ /$scheme_re_sans_colon$/;
        Carp::croak("Scheme '$new' not found in $found_services_in") unless $SERVICE_PORTS{lc $new};

        $old = $1 if $$self =~ s/$scheme_re//;
        my $newself = __PACKAGE__->new("$new:$$self");
        $$self = $$newself;
        bless $self, ref($newself);
    }
    else {
        $old = $1 if $$self =~ $scheme_re;
    }

    return $old;
}

sub default_port {
    my ($self) = @_;
    return $SERVICE_PORTS{$self->scheme};
}

1;

=pod

=encoding UTF-8

=head1 NAME

URI::AnyService - Simple /etc/services-driven URI objects

=head1 VERSION

version v0.90.0

=head1 SYNOPSIS

    use URI;
    use URI::AnyService;

    my $uri = URI->new('smtp://example.com');
    say $uri->has_recognized_scheme;  # !!0
    say $uri->port;                   # ''

    my $uas = URI::AnyService->new('smtp://example.com');
    say $uas->has_recognized_scheme;  # !!1
    say $uas->port;                   # 25

=head1 DESCRIPTION

This module creates simple L-based objects for protocols that it doesn't yet have defined.
It works just like L, except it just supports the L,
and not anything scheme-specific.  In other words, most of the methods that C/C
objects support.

Port numbers are looked up from a C file.  If you don't have a C
file, one will be provided for you, but there's no guarantee that it will be up-to-date or apply
to your specific protocol.

This allows you to use a URL like C without having to set a default port in
the URL.

=head1 GLOBAL VARIABLES

=head2 %SERVICE_PORTS

This is a hash of schemes/protocols to port numbers.  It is loaded from the C file,
as soon as you C this module.

Most of the time, you shouldn't mess with this.  But, if there is some new protocol that you need
to add that happens to not exist in your C files, you can do so with:

    $URI::AnyService::SERVICE_PORTS{'my-protocol'} = 1234;

This variable is not exportable, so you need to use the full package syntax.

=head1 USE OPTIONS

=head2 :InternalServicesData

    use URI::AnyService ':InternalServicesData';

This will force the internal services data to be loaded, even if the C file is
available.  This is useful for testing, or if you know that the C files on your
servers are not consistent.

Please note that there are no guarantees that the internal data is up-to-date or accurate.  It's
mostly used as a "last resort" fallback.

=head1 CONSTRUCTOR

    URI::AnyService->new($str);
    URI::AnyService->new($str, $scheme);

This constructor is very similiar to L, including the
somewhat-legacy two parameter form.  In most cases, you should just use the whole URL string.

A scheme that was defined in the services file is required.

=head1 AUTHOR

Grant Street Group

=head1 COPYRIGHT AND LICENSE

This software is Copyright (c) 2025 by Grant Street Group.

This is free software, licensed under:

  The Artistic License 2.0 (GPL Compatible)

=cut

__DATA__