url() relative navigation

1 files changed, 133 insertions, 26 deletions

diff --git a/gmi.pl b/gmi.pl
index 2de0eb8..85d0df7 100755
--- a/gmi.pl
+++ b/gmi.pl
@@ -4,16 +4,16 @@
 
 use strict;
 use warnings;
+#use diagnostics;
 use utf8;
 use bytes;
 use feature qw(refaliasing);
 no warnings qw(experimental::refaliasing);
 
-our $VERSION = 'v0.0.14';
+our $VERSION = 'v0.0.15';
 
 # TODO: 
 # back() only works once; should fix this
-# url() should also handle relative paths
 
 # Modules
 use IO::Socket::SSL;									  # CPAN
@@ -34,11 +34,18 @@ my $doc;
 my @links;
 my $current_url = "";
 my @history;
-my $prompt = "gmi> ";
+my $prompt = "$current_url> ";
 
 my %commands = (
-	'url' => [sub { url($_[0]) }, 'Go to the specified URL.'],
-	'u' => [sub { url($_[0]) }, 'Alias of `url\''],
+	'url' => [sub { url($_[0],0) }, 'Go to the specified URL.'],
+	'u' => [sub { url($_[0],0) }, 'Alias of `url\''],
+	
+	'urlrelative' => [sub { url($_[0],1) }, "Navigate the current URL relatively.\n\n"
+		."Note: if the current path is '/blog/my-post1.gmi' and 'my-post2.gmi'\n" .
+		"was supplied then the resulting path will be: 'blog/my-post1.gmi/my-post2.gmi'\n" .
+		"which is probably not what you want; in that case use '../my-post2.gmi'.\n\n" .
+		"The very end of the path is treated like a directory which can be confusing."],
+	'ur' => [sub { url($_[0],1) }, 'Alias of `urlrelative\''],
 
 	'cwu' => [sub { cwu() }, 'Returns the current working URL.'],
 	'c' => [sub { cwu() }, 'Alias of `cwu\'.'],
@@ -74,7 +81,7 @@ my %commands = (
 		"automatically determine the appropriate length. (Currently $wrapper->{columns})"],
 	'pager' => [sub { pager($_[0]) }, "Set which pager to use. (currently $ENV{pager})"],
 	'save' => [sub { ; }, 'Save the config settings. (Not yet implimented)'],
-	'help' => [sub { help($_[0]); }, 'Use help before a command to get extra info.'],
+	'help' => [sub { help($_[0]); }, 'Use help before a command to get extra info. (cmds to see commands)'],
 	'cmds' => [sub {cmds()}, 'Returns the available commands.'],
 	'ver' => [sub {print "$VERSION\n"}, "Returns the version ($VERSION)"],
 	'exit' => [sub {exit 0;}, "This exits the program with a status code of 0."],
@@ -83,10 +90,11 @@ my %commands = (
 print "Type 'cmds' to see available commands.\n";
 while () {
 
+	$prompt = "$current_url> ";
 	print "$prompt";
 	chomp(my $input = <STDIN>);
 
-	### $input
+	# ## $input
 	if ($input) {
 		my ($command, $detail) = split(/\s/, $input);
 		do_command(\$command, \$detail);
@@ -97,7 +105,7 @@ sub do_command {
 	# referenced command, referenced detail 
 	my ($rCmd, $rDetail) = @_; 
 
-	### @_
+	# ## @_
 	# checking if %commands even has the command
 	if (exists $commands{$$rCmd}) {
 
@@ -127,23 +135,62 @@ sub help {
 }
 
 sub url {
-	my ($url) = @_;
-	if (!$url) { print("Example: [gemini://]capsule.com/\n"); return 0;}
+	# technically 'gemini://john/blog/thing.gmi' can be a valid url
+	# where 'john' is the host
+	# which makes determining relative movements a pain
+	#
+	# mode 0 = 'john' can be a host, 1 = 'john' is actually relative movement
+	my ($url, $mode) = @_;
+	### $url
+	if (!$url) { print("Example: [gemini://]capsule.com/\n"); return 1;}
 	if ( $url !~ m|^.*://.*|) {
 		$url = "gemini://$url";
 	}
-	### $url
 	$url = parse_url($url);
+	### $url
+	
+	# relative movement
+	if ($mode eq 1) {
+		if (!$current_url) {print "Relative movement impossible: no current URL.\n"; return 1;}
+		my $c_url = parse_url($current_url);
+
+		if ($url->{path}) {
+			$url->{path} = "$url->{host}/$url->{path}";
+		}
+		else {
+			delete($url->{path}); # DO NOT DELETE THIS LINE (P)
+			$url->{path} = "$url->{host}"; 
+		}
+		$url->{host} = $c_url->{host};
+		$url->{port} = $c_url->{port};
+
+		my $cp_url = split_url_path($c_url->{path}, 256);
+		$c_url->{path} = '';
+
+		#if ( $url->{path} =~ m|\.\.| or $url->{path} =~ m|^\./?|) {
+		#	pop(@$cp_url);
+		#}
+		for (@$cp_url) {
+			$c_url->{path} .= "$_/"
+		}
+
+		$c_url->{path} = "/$c_url->{path}/$url->{path}"; # adding first / for normalize_path
+		$c_url->{path} = normalize_path($c_url->{path});
+		substr($c_url->{path}, 0, 1, ''); # removing the first /
+		$url->{path} = $c_url->{path};
+	}
+
+	### $url
+	if (! $url->{port} or $url->{port} eq 0) {
+		$url->{port} = '1965';
+	}
 	
 	my $cl = IO::Socket::SSL->new(
 		PeerHost => "$url->{host}",
-		PeerPort => '1965',
+		PeerPort => "$url->{port}",
 	
 		SSL_verify_mode => SSL_VERIFY_NONE,
-		# will update version when support is better or
-		# when gemini removes TLSv1_2 as a supported version
-		SSL_version => 'TLSv1_2',
-	
+		SSL_version => '!SSLv2:!SSLv3:!TLSv1:!TLSv1_1',
 	); 
 
 	if ($cl) {
@@ -155,10 +202,14 @@ sub url {
 			$path = "$url->{path}";
 		}
 		
-		$current_url = "$url->{scheme}://$url->{host}/$path";
+		#$current_url = "$url->{scheme}://$url->{host}/$path";
+		$current_url = return_url($url);
+		### $current_url
+		### $url
 
 		# ["absolute_url", "description"]
-		update_history( ["$url->{scheme}://$url->{host}/$path", "$url->{host}/$path"] );
+		#update_history( ["$url->{scheme}://$url->{host}/$path", "$url->{host}/$path"] );
+		update_history( ["$current_url", ""] );
 	
 		# gemini spec: <URL><CR><LF>
 		# <URL> is an absolute path
@@ -181,6 +232,55 @@ sub url {
 	}
 }
 
+sub return_url {
+	#my ($scheme, $username, $password, $host, $port, $path, $query, $fragment) = @_;
+	my ($url) = @_;
+	my $url_string;
+	### @_
+	if (ref($url) ne 'HASH') { # assuming string
+		if ($url !~ m|.*://|) {
+			$url =~ s|(.*)|gemini://$1|;
+		}
+		$url = parse_url($url);
+	}
+	my $scheme = $url->{scheme};
+	my $username = $url->{username};
+	my $password = $url->{password};
+	my $host = $url->{host};
+	my $port = $url->{port};
+	my $path = $url->{path};
+	my $query = $url->{query};
+	my $fragment = $url->{fragment};
+	
+	# 'https://peter:bro@localhost:8989/some/path/to/resource?q1=yes&q2=no&q3=maybe#frag=1';
+	# a valid url ^^
+	if (! $scheme) {
+		$url_string .= "gemini://";
+	} 
+	else {
+		$url_string .= "$scheme://";
+	}
+	if ($username and $password) {
+		$url_string .= "$username:$password@";
+	} elsif ($username) {
+		$url_string .= "$username@";
+	}
+	$url_string .= "$host" if ($host);
+	if ($port and $port ne 1965) {
+		$url_string .= ":$port";
+	}
+	$url_string .= "/";
+	$url_string .= "$path" if ($path);
+	$url_string .= "?$query" if ($query);
+	$url_string .= "#$fragment" if ($fragment);
+
+	#$url = "$host/$path/$url";
+	#$url = normalize_path($url);
+	#$url = "$scheme://$url";
+	# ## $c_url;
+	return $url_string;
+}
+
 sub get_links {
 	undef(@links);
 	my ($doc) = @_;
@@ -263,14 +363,16 @@ sub nav {
 		return 1;
 	}
 
-	# This implies it is valid
+	# This implies it is valid fqdn
 	if (has_scheme($link)) {
 		url("$link");
 	}
 	else {
+		my $c_url = parse_url($current_url);
+		# relative navigation madness
+		# ../../blog/my-post.gmi
 		if ($link =~ m|\.{1,2}/.*|) {
-			my $new_url = parse_url($current_url);
-			my $parsed_url_path = split_url_path($new_url->{path}, 256);
+			my $parsed_url_path = split_url_path($c_url->{path}, 256);
 			my $url_path;
 
 			# request doc will be different
@@ -278,15 +380,20 @@ sub nav {
 			for (@$parsed_url_path) {
 				$url_path .= "/$_";
 			}
+			substr($url_path, 0, 1, ''); # removing the first /
 			### $url_path
 			### $link
-			my $path = normalize_path("$url_path/$link");
+			$c_url->{path} = normalize_path("$url_path/$link");
 
-			url("$new_url->{scheme}://$new_url->{host}$path");
+			#url("$new_url->{scheme}://$new_url->{host}$path");
+			url(return_url($c_url));
 		}
+		# normal navigation of current domain, probably something like:
+		# blog/my-post.gmi
 		else {
-			my $new_url = parse_url($current_url);
-			url("$new_url->{scheme}://$new_url->{host}/$link");
+			#url("$new_url->{scheme}://$new_url->{host}/$link");
+			$c_url->{path} = "$link";
+			url(return_url($c_url));
 		}
 	}
 }
@@ -385,7 +492,7 @@ sub pager {
 sub cmds {
 	my $c;
 	for (sort keys %commands) {
-		$c .= "$_ ";
+		$c .= "$_  ";
 	}
 	print $wrapper->wrap($c);
 }