view release on metacpan or  search on metacpan

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

	# Remove the first path segment, as it is q{}
	if (@path_segments && $path_segments[0] eq q{}) {
		shift @path_segments;
	}

	if (@new_part_name_segments) {
		# Set the new part name
		$self->part_name(q{/} . join q{/}, @new_part_name_segments);
	}

	return @path_segments;
}

###############################################################################
# PRIVATE METHODS
sub _check_uri {
	my ($self) = @_;

	# If the URI has a part name, check it
	if ($self->has_part_name) {
		# Check the part
		$self->_is_valid_part_uri($self->path);
	}

	# Must have either package or part name
	if (!$self->has_package_uri && !$self->has_part_name) {
		croak 'Not a valid URI';
	}

	return $self;
}
sub _init { ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)
	my ($class, $uri, $scheme) = @_;

	# Create and bless into class using default _init
	my $self = $class->SUPER::_init($uri, $scheme);

	# Check the URI
	$self->_check_uri();

	return $self;
}
sub _is_valid_part_uri {
	my ($self, $part_uri) = @_;

	# Validate a part URI according to ECMA-376 Part 2, section 9.1.1.1.2

	if ($part_uri eq q{}) {
		croak 'A part URI shall not be empty [M1.1]';
	}

	if ($part_uri !~ m{\A /}msx) {
		croak 'A part URI shall start with a forward slash ("/") character [M1.4]';
	}

	if ($part_uri =~ m{/ \z}msx) {
		croak 'A part URI shall not have a forward slash as the last character [M1.5]';
	}

	# Split the part URI into segments
	my @segments = split m{/}msx, $part_uri;

	# Remove the first empty segment
	if ($segments[0] eq q{}) {
		shift @segments;
	}

	foreach my $segment (@segments) {
		if ($segment eq q{}) {
			croak 'A part URI shall not have empty segments [M1.3]';
		}

		if ($segment !~ m{\A (?:$PCHAR)+ \z}msx) {
			croak 'A segments shall not hold any characters other than pchar characters [M1.6]';
		}

		if ($segment =~ m{\%(?:2f|5c)}imsx) {
			croak 'A segments shall not contain percent-encoded forward slash ("/"), or backward slash ("\") characters [M1.7]';
		}

		while ($segment =~ m{%([0-9a-f]{2})}gimsx) {
			# Convert the byte into the original character
			my $character = chr hex $1;

			if ($character =~ m{\A [0-9A-Z\-\._~] \z}imsx) {
				croak 'A segment shall not contain percent-encoded unreserved characters [M1.8]';
			}
		}

		if ($segment =~ m{\. \z}msx) {
			croak 'A segment shall not end with a dot (".") character [M1.9]';
		}

		if ($segment !~ m{[^\.]+}msx) {
			croak 'A segment shall include at least one non-dot character [M1.10]';
		}
	}

	return 1;
}
sub _no_scheme_ok { return 0; } ## no critic (Subroutines::ProhibitUnusedPrivateSubroutines)

1;

__END__

=head1 NAME

URI::pack - Support of the pack scheme in URI.

=head1 VERSION

This documentation refers to version 0.002001.

=head1 SYNOPSIS

  use URI;

  # New absolute pack URI
  my $pack_uri = URI->new('pack://application,,,/ResourceFile.xaml');