diff options
| -rwxr-xr-x | gmi.pl | 159 |
1 files changed, 133 insertions, 26 deletions
@@ -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); } |