view release on metacpan or  search on metacpan

URI/Pure.pm  view on Meta::CPAN

	return $p unless $p =~ m/\.\// or $p =~ m/\/\./ or $p =~ m/\/\//;

	my $is_abs = $p =~ m/^\// ? 1 : 0;
	my $is_dot = $p =~ m/^\./ ? 1 : 0;
	my $is_dir = ($p =~ m/\/$/ or $p =~ m/\/\.$/ or $p =~ m/\/\.\.$/) ? 1 : 0;

	my @p = split "/", $p;
	shift @p if $is_abs;

	my @n = ();
	foreach my $i (@p) {
		$i or next;
		if ($i eq "..") {
			if ($is_abs) {
					pop @n;
			} else {
				if (@n and $n[0] ne "..") {
					pop @n;
				} else {
					push @n, $i;
				}
			}
		} elsif ($i ne ".") {
			push @n, $i;
		}
	}

	my $r = join "/", ($is_abs ? "" : ()), @n, ($is_dir ? "" : ());
	$r ||= "." if $is_dot;
	return $r;
}



sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;

	my ($uri) = @_;
	if (Encode::is_utf8($uri)) {
		warn "URI must be without utf8 flag: $uri";
		return;
	}

	my ($scheme, $authority, $path, $query, $fragment) =
		$uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
			# На основе взятого из URI (это также рекомендуется в RFC 3986)
			# =head1 PARSING URIs WITH REGEXP
			# Смотри также URI::Split

	my ($user, $password, $host, $port) = $authority =~ m/^(?:([^:]+)(?::(.+))?\@)?([^:]+)(?::(\d+))?$/ if $authority;

	$scheme = lc $scheme if $scheme;

	if ($host) {
		if ($host =~ m/[^\p{ASCII}]/) {
			$host = join ".", map {
				if (m/[^\p{ASCII}]/) {
					my $p = decode_utf8 $_;
					$p =~ s/\x{202b}//g;  # RIGHT-TO-LEFT EMBEDDING
					$p =~ s/\x{202c}//g;  # POP DIRECTIONAL FORMATTING
					join "", "xn--", encode_punycode fc $p;
				} else {
					$_;
				}
			} split /\./, $host;
		} else {
			$host = lc $host;
		}
	}


	$path = _normalize($path) if $path;

	$path  = uri_escape($path) if $path;

	$query = uri_escape($query) if $query;

	my $self = {
		scheme    => $scheme,
		user      => $user,
		password  => $password,
		host      => $host,
		port      => $port,
		path      => $path,
		query     => $query,
		fragment  => $fragment,
	};

	bless $self, $class;
	return $self;
}



foreach my $method (qw(scheme user password host port path query fragment)) {
 	no strict 'refs';
 	*$method = sub { my $self = shift; return $self->{$method} };
}



sub _as {
	my $self = shift;
	my ($iri) = @_;

	my @as_string = ($self->{scheme}, ":") if $self->scheme;

	push @as_string, "//" if $self->{host};

	if ($self->{user}) {
		push @as_string, $self->{user};
		push @as_string, ":", $self->{password} if $self->{password};
		push @as_string, "@";
	}

	if (my $host = $self->{host}) {
		if ($iri and $host =~ m/xn--/) {
			$host = join ".", map {
				if (m/^xn--/) {