view release on metacpan or  search on metacpan

lib/URI/AnyService.pm  view on Meta::CPAN

#pod to your specific protocol.
#pod
#pod This allows you to use a URL like C<smtp://example.com> 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</etc/services> file,
#pod as soon as you C<use> 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</etc/services> 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</etc/services> file is
#pod available.  This is useful for testing, or if you know that the C</etc/services> 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 = '<DATA>';
    }

    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<URI's version|URI/CONSTRUCTORS>, 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 (@_) {