diff options
author | jake <jake@jakes-mail.top> | 2022-02-02 18:11:22 -0500 |
---|---|---|
committer | jake <jake@jakes-mail.top> | 2022-02-02 18:11:22 -0500 |
commit | d9e3a77d0731df7dc51e5923f069a1b83b7102dd (patch) | |
tree | 31a6fa2dae38a1d64bca9d4b0d05a486c16cd810 /gmi.pl | |
parent | a7cacde8a841b8b56e48cc07228e827af79541e8 (diff) |
now able to access links on the page
Diffstat (limited to 'gmi.pl')
-rwxr-xr-x | gmi.pl | 646 |
1 files changed, 233 insertions, 413 deletions
@@ -28,31 +28,47 @@ use warnings; use feature qw(refaliasing); no warnings qw(experimental::refaliasing); -our $VERSION = 'v1.0.1'; +our $VERSION = 'v1.0.1Tk'; # Modules use IO::Socket::SSL; # CPAN use URL::XS qw(parse_url split_url_path parse_url_query); # CPAN use IO::Pager; # CPAN require Text::Wrapper; # CPAN -use Term::ReadKey; # CPAN +#use Term::ReadKey; # CPAN use Term::ANSIColor; # Core use Path::Naive qw(normalize_path); # CPAN #use Text::ParseWords; # Core use Term::ReadLine; # CPAN -#use Smart::Comments; # CPAN +use Smart::Comments; # CPAN use URI::Encode qw(uri_encode); # CPAN use IO::Socket::SSL::Utils; # CPAN use File::Slurper qw(read_dir read_text); # CPAN -#use Data::Dumper; # Core +use Data::Dumper; # Core use File::BaseDir qw(xdg_config_home xdg_data_home xdg_cache_home); # CPAN use TOML qw(from_toml to_toml); # CPAN use Tk; use Tk::Text; +use Tk::TextANSIColor; # sudo cpanm IO::Socket::SSL URL::XS IO::Pager Text::Wraper Term::ReadKey Path::Naive Text::ParseWords Term::ReadLine Smart::Comments URI::Encode IO::Socket::SSL::Utils File::Slurper File::BaseDir TOML Tk -my $top = MainWindow->new; + + +my $top = MainWindow->new( + -title=>'Gmi Main Window' + ); + + +my(@bold, @normal, $tag); +if ($top->depth > 1) { + @bold = (-background => '#43ce80', qw/-relief raised -borderwidth 1/); + @normal = (-background => undef, qw/-relief flat/); +} +else { + @bold = (qw/-foreground white -background black/); + @normal = (-foreground => undef, -background => undef); +} my $control_frame = $top->Frame() ->pack( @@ -83,7 +99,7 @@ my $body_frame = $top->Frame() -expand=>1, ); my $t = $body_frame->Scrolled( - 'Text', + 'TextANSIColor', -relief=>'sunken', -borderwidth=>2, -setgrid=>'true', @@ -98,15 +114,13 @@ my $t = $body_frame->Scrolled( my $something = "hello world"; $t->insert('0.0', "$something"); - - my %config = ( 'use_pager' => 1, 'pager_text_wrap_auto' => 1, 'textwrap' => 70, # not used if pager_text_warp_auto is 1 'timeout' => 10, 'pretty_links' => 0, - 'pretty_headers' => 0, + 'pretty_headers' => 1, 'auto_redirect' => 3, 'pager' => 'less -R', 'doc_out' => 1, @@ -152,163 +166,25 @@ MainLoop; #my $wrapper = Text::Wrapper->new(columns=>$config{textwrap}, body_start=>''); #$ENV{PAGER} = $config{pager}; -my $term=new Term::ReadLine "hmm, what goes here?"; -my $OUT = $term->OUT || \*STDOUT; -#my $OUT = \*STDOUT; sub go_to_url { url($entry->get()); } -my %commands = ( - 'url' => [sub { url($_[0]) }, 'Go to the specified URL.'], - 'u' => [sub { url($_[0]) }, 'Alias of `url\''], - - 'urlrelative' => [sub { urlrelative($_[0]) }, "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-post2.gmi'\n" . - "which is probably what you want. You can also use './my-post2.gmi'.\n" . - "'.', of course, means 'same directory', in this case '/blog/'.\n\n" . - "To remove the forward slash ('/') at the end of the current url,\n" . - "type the back-slash ('\\') by itself.\n\n" . - "urlrelative without an argument will remove the ending '/' or go\n" . - "up a directory without appending a forward slash.\n" . - "IE: '/blog/drafts/secret/post.gmi -> '/blog/drafts/secret' -> '/blog/drafts'"], - 'ur' => [sub { urlrelative($_[0]) }, 'Alias of `urlrelative\''], - - 'cwu' => [sub { print $OUT "$current_url\n"; }, 'Returns the current working URL.'], - 'c' => [sub { print $OUT "$current_url\n"; }, 'Alias of `cwu\'.'], - - 'links' => [sub { links() }, 'Returns the links on the current page.'], - 'l' => [sub { links() }, 'Alias of `links\'.'], - - 'nav' => [sub { nav(0, $_[0]) }, 'Navigate to a link that is on the current page (use links)'], - 'n' => [sub { nav(0, $_[0]) }, 'Alias of `nav\'.'], - - 'navh' => [sub { nav(1, $_[0]) }, 'Navigate to a URL specified from history (use hist)'], - 'nh' => [sub { nav(1, $_[0]) }, 'Alias of `navh\'.'], - - 'navb' => [sub { nav(2, $_[0]) }, 'Navigate to a URL specified from bookmarks (use bookmarks)'], - 'nb' => [sub { nav(2, $_[0]) }, 'Alias of `navh\'.'], - - - 'root' => [sub { root() }, 'Go to the root of the current URL.\n' . - 'Exp: gemini://capsule.com/blog/2020112.gmi -> gemini://capsule.com/' ], - - 'hist' => [sub { hist() }, 'Returns history.' ], - 'h' => [sub { hist() }, 'Alias of `hist\'.' ], - - 'back' => [sub { back(0) }, 'Go back in history, once. The previously accessed URI is cached.' ], - 'b' => [sub { back(0) }, 'Alias of `back\'.' ], - - 'backnodisplay' => [sub { back(1) }, 'Go back in history but do not display the page' . - '(still accesses the resource).' ], - 'bd' => [sub { back(1) }, 'Alias of `backnodisplay\'.'], - - 'display' => [sub { display() }, 'Display the current page.' ], - 'd' => [sub { display() }, 'Alias of `display\'.' ], - - 'usepager' => [sub { toggle($config{use_pager}) }, 'This toggles pager use. 1 = use pager, 0 = stdout.' ], - 'pretty_links' => [sub { toggle($config{pretty_links}) }, "0 = do nothing, 1 = pretty."], - 'pretty_headers' => [sub { toggle($config{pretty_headers}) }, "0 = do nothing, 1 = pretty."], - 'textwrap' => [sub { textwrap($_[0]) }, "Set textwrap length.\nGiving 'auto' will " . - "automatically determine the appropriate length."], - 'pager' => [sub { pager($_[0],$_[1]) }, "Set which pager to use. (currently $config{pager})"], - 'save-config' => [sub { save_config() }, 'Save the config settings.'], - 'load-config' => [sub { load_config() }, "Load the config settings.\n" . - 'This is not needed as the configs are loaded when the program is started.' ], - 'help' => [sub { help($_[0]); }, 'Use help before a command to get extra info.' . - '(<tab><tab> to see commands)'], - 'ver' => [sub {print $OUT "$VERSION\n"}, "Returns the version ($VERSION)"], - 'exit' => [sub {begin_exit();}, "This exits the program with a status code of 0."], - - 'autoredirection' => [sub { value_number($config{auto_redirect},$_[0],'autoredirect') }, - "The amount of times this program is allowed to auto redirect. 0 = none."], - 'timeout' => [sub { value_number($config{timeout},$_[0],'timeout') }, - "The client will time out when the server takes too long." ], - - 'clearquery' => [sub { clear_query() }, "Removes query from current URL"], - 'cq' => [sub { clear_query() }, "Alias of `clearquery'"], - - 'reload' => [sub {url($current_url)}, "Reload the current URL."], - 'r' => [sub {url($current_url)}, "Alias of `reload'."], - - 'cert-create' => [sub { cert_create() }, "Create a cert. Interactive."], - 'cert-use' => [sub { cert_use() }, "Use a cert. Interactive.\n" . - "If a cert has already been loaded, it will unload it."], - 'cert-del' => [sub {cert_del() }, "Delete a cert. Interactive." ], - - 'keep-history' => [sub {toggle($config{keep_history})}, 'Toggle whether to save history to disk or not,' . - ' after \'exit\'. By default it does not.' ], - 'clear-history' => [sub { undef(@history) }, 'Clears your history. (The file itself is very parsable)' ], - - 'bookmark-add' => [sub { bookmark_add($_[0]) }, 'Add bookmark. ' . - 'No argument means the current url, otherwise what was supplied.'], - 'bookmark-del' => [sub { bookmark_del($_[0]) }, 'Delete bookmark by number' . - ' (use \'bookmarks\' to see numbers).'], - 'bookmarks' => [sub { bookmarks(); }, 'Returns your bookmarks. Use \'nb\' or \'navb\' along with this.'], -); - -#my @completions = keys %commands; -# -#$term->Attribs->{'do_expand'}=1; -#$term->Attribs->{'completion_entry_function'} = $term->Attribs->{'list_completion_function'}; -#$term->Attribs->{'completion_word'} = \@completions; -#$term->ornaments(0); -# -#$prompt = "$current_url > "; -# -##print $OUT "gmi.pl Copyright (C) 2022 Jake Thoughts\n"; -##print $OUT "This program comes with ABSOLUTELY NO WARRANTY.\n"; -##print $OUT "This is free software, and you are welcome to redisdtribute it\n"; -##print $OUT "under certain conditions. See COPYING for details.\n"; -##print $OUT "Press <tab><tab> to see available commands.\n"; -##while ( defined ($_ = $term->readline($prompt)) ) { -## if ($_) { -## my ($command, $detail, @other_details) = split(/\s/, $_); -## do_command(\$command, \$detail, @other_details); -## } -## $prompt = "$current_url > "; -##} -# -#sub do_command { -# # referenced command, referenced arg, additional args -# my ($rCmd, $rArg, $rArgs) = @_; -# -# ### @_ -# # checking if %commands even has the command -# if (exists $commands{$$rCmd}) { -# -# # assigning a reference to a subroutine to the value -# my $rsub = $commands{$$rCmd}[0]; -# -# #running the subroutine -# &$rsub($$rArg,$rArgs); -# -# } -# # options doesn't have the command -# else { -# print $OUT "Command is invalid.\n"; -# } -#} -# -#sub help { -# my ($cmd) = @_; -# ### @_ -# if ($cmd and exists $commands{$cmd}) { -# print $OUT "$commands{$cmd}[1]\n"; -# } elsif ($cmd) { -# print $OUT "`$cmd' isn't an avaliable command.\n"; -# } -# else { -# print $OUT "$commands{help}[1]\n" -# } -#} +sub show_to_user { + my ($text) = @_; + my $window=$top->Toplevel( + -title=>'Gmi' + ); + my $label=$window->Label( + -text=>"$text", + )->pack(); +} sub url { my ($url) = @_; ### $url - if (!$url) { print("Example: [gemini://]capsule.com/\n"); return 1;} + if (!$url) { show_to_user("Example: [gemini://]capsule.com/\n"); return 1;} if (! has_scheme($url) ) { $url = "gemini://$url"; } @@ -317,7 +193,7 @@ sub url { $url = parse_url($url); }; if ($@) { - print $OUT "$@\n"; + show_to_user( "$@\n"); return 0; } @@ -384,7 +260,7 @@ sub url { }; if ($@) { - print $OUT "Timed out after $config{timeout} seconds - server is taking too long.\n"; + show_to_user( "Timed out after $config{timeout} seconds - server is taking too long.\n"); update_history( ["$current_url", "timed out"] ); ### @doc } else { @@ -392,12 +268,12 @@ sub url { } } else { - print $OUT "Not connecting\n"; + show_to_user( "Not connecting\n"); } } else { - print $OUT "error=$!, ssl_error=$SSL_ERROR\n"; + show_to_user( "error=$!, ssl_error=$SSL_ERROR\n"); } } @@ -409,7 +285,7 @@ sub peer_cert { my ($cl, $hostname) = @_; # ## before CERT_asHash my @peer_certs = $cl->peer_certificates; - #print $OUT Dumper(\@peer_certs); + #show_to_user( Dumper(\@peer_certs)); # # if the server sends us more than ONE cert then I am baffled as to why but it happens my $peer_cert = CERT_asHash($peer_certs[0]); @@ -425,7 +301,7 @@ sub peer_cert { ### $verify_hostname if (! $verify_hostname) { - print $OUT "The server offers a cert that doesn't match their domain name.\n"; + show_to_user( "The server offers a cert that doesn't match their domain name.\n"); return 0; } @@ -438,11 +314,11 @@ sub peer_cert { } else { # fingerprint NOT same - print $OUT colored("!!! THE HOST'S FINGERPRINT IS NOT THE SAME !!!\n", 'bright_red'); - print $OUT "Do you still wish to connect to it? y/N "; + show_to_user( colored("!!! THE HOST'S FINGERPRINT IS NOT THE SAME !!!\n", 'bright_red')); + show_to_user( "Do you still wish to connect to it? y/N "); chomp(my $yORn = <STDIN>); if (lc $yORn eq 'y') { - print $OUT "Would you like to replace the known_hosts fingerprint with this one? y/N "; + show_to_user( "Would you like to replace the known_hosts fingerprint with this one? y/N "); chomp(my $yORn = <STDIN>); if (lc $yORn eq 'y') { $known_hosts{$hostname} = $peer_fingerprint; @@ -465,7 +341,7 @@ sub peer_cert { } else { ### expired! - print $OUT "The host has an expired certificate. Connect anyway? y/N "; + show_to_user( "The host has an expired certificate. Connect anyway? y/N "); chomp(my $yORn = <STDIN>); if (lc $yORn eq 'y') { ; @@ -498,60 +374,60 @@ sub follow_status_code { } } else { - print $OUT $bad_code; + show_to_user( $bad_code); } } elsif ($status_code1 == 1) { if ($status_code2 == 0) { - print $OUT "Server wants you to type something:\n@doc"; + show_to_user( "Server wants you to type something:\n@doc"); } elsif ($status_code2 == 1) { - print $OUT "Server wants you to type something secretly (do note: not secure):\n@doc"; - ReadMode 2; + show_to_user( "Server wants you to type something secretly (do note: not secure):\n@doc"); + #ReadMode 2; } else { - print $bad_code; - print $OUT "\nPresumably, the server wants you to type something:\n"; + show_to_user("$bad_code"); + show_to_user( "\nPresumably, the server wants you to type something:\n"); } chomp(my $input = <STDIN>); $input = uri_encode($input); - ReadMode 1; + #ReadMode 1; url("$current_url?$input"); clear_query(); } elsif ($status_code1 == 3) { - print $bad_code if ($status_code2 !~ m/^0|1$/); # not worrying about permanent/temporary yet - print $OUT "Redirecting anyway.\n" if ($status_code2 !~ m/^0|1$/); + show_to_user($bad_code) if ($status_code2 !~ m/^0|1$/); # not worrying about permanent/temporary yet + show_to_user( "Redirecting anyway.\n") if ($status_code2 !~ m/^0|1$/); if ($config{auto_redirect}) { $auto_redirect_count++; if ($auto_redirect_count < $config{auto_redirect}) { - print $OUT "Redirection...\n"; + show_to_user( "Redirection...\n"); ### @status_code access_resource($status_code[1]); # redirection can be './hello.gmi' } else { - print $OUT "Reached limit for auto redirection.\n@doc"; + show_to_user( "Reached limit for auto redirection.\n@doc"); } } else { - print $OUT "The server wants to redirect us, however, autoredirect has turned off.\n@doc"; + show_to_user( "The server wants to redirect us, however, autoredirect has turned off.\n@doc"); } $auto_redirect_count = 0; } elsif ($status_code1 == 4) { if ($status_code2 == 0) { - print $OUT "Temporary failure.\n@doc"; + show_to_user( "Temporary failure.\n@doc"); } elsif ($status_code2 == 1) { - print $OUT "Server is unavailable (yet somehow sent a reply to us).\n@doc"; + show_to_user( "Server is unavailable (yet somehow sent a reply to us).\n@doc"); } elsif ($status_code2 == 2) { - print $OUT "Server's CGI script is broken.\n@doc"; + show_to_user( "Server's CGI script is broken.\n@doc"); } elsif ($status_code2 == 3) { - print $OUT "Server was unable to proxy content.\n@doc"; + show_to_user( "Server was unable to proxy content.\n@doc"); } elsif ($status_code2 == 4) { if (!$sleep) { $sleep = 5; - print $OUT "Server wants us to slow down.\n" . + show_to_user("Server wants us to slow down.\n" . "Reconnecting after $sleep seconds\n" . "Press 'ctrl-C' to cancel sleep\n" . - "@doc\n"; + "@doc\n"); eval { local $SIG{INT} = sub { die "Cancelling Sleep!\n" }; sleep ($sleep); # give the server an extra second @@ -559,125 +435,125 @@ sub follow_status_code { } } else { - print $OUT "The server is asking us to slow down and try again.\n" . - "We have already done this once: not doing it again.\n"; + show_to_user("The server is asking us to slow down and try again.\n" . + "We have already done this once: not doing it again.\n"); } undef($sleep); } else { - print $bad_code; + show_to_user("$bad_code"); } } elsif ($status_code1 == 5) { if ($status_code2 == 0) { - print $OUT "Permanent failure. Requests to this URI will reliably fail.\n@doc"; + show_to_user( "Permanent failure. Requests to this URI will reliably fail.\n@doc"); } elsif ($status_code2 == 1) { - print $OUT "Not found. Not available but *may* be in the future\n@doc"; + show_to_user( "Not found. Not available but *may* be in the future\n@doc"); } elsif ($status_code2 == 2) { - print $OUT "Gone. This resource will not be available again.\n@doc"; + show_to_user( "Gone. This resource will not be available again.\n@doc"); } elsif ($status_code2 == 3) { - print $OUT "Proxy Request Refused. Resource not served by this server and this\n" . - "server does not accept proxy requests.\n@doc"; + show_to_user("Proxy Request Refused. Resource not served by this server and this\n" . + "server does not accept proxy requests.\n@doc"); } elsif ($status_code2 == 9) { - print $OUT "Bad Request. The server is unable to parse our request.\n@doc"; + show_to_user( "Bad Request. The server is unable to parse our request.\n@doc"); } else { - print $bad_code; + show_to_user($bad_code); } } elsif ($status_code1 == 6) { if ($status_code2 == 0) { - print $OUT "The server is asking you for a certificate. (cert-use to load a cert)\n@doc"; + show_to_user( "The server is asking you for a certificate. (cert-use to load a cert)\n@doc"); } elsif ($status_code2 == 1) { - print $OUT "The certificate you supplied is not authorized to access this resource.\n@doc"; + show_to_user( "The certificate you supplied is not authorized to access this resource.\n@doc"); } elsif ($status_code2 == 2) { - print $OUT "The certificate you supplied is malformed. There is something wrong with it.\n@doc"; + show_to_user( "The certificate you supplied is malformed. There is something wrong with it.\n@doc"); } else { - print $OUT $bad_code; + show_to_user( $bad_code); } } else { - print $OUT $bad_code; + show_to_user( $bad_code); } ### @status_code; } -sub urlrelative { - my ($urlr) = @_; - if (! $urlr) { $urlr = ""} - if (! $current_url) {print $OUT "Relative movement impossible: no current URL.\n"; return 1;} - my $end_with_slash = 1 if ($urlr =~ m|/$|); - my $dot_only = 1 if ($urlr =~ m|^\.$|); - my $dot_2_only = 1 if ($urlr =~ m|^\.\.$|); # since we are going up into a dir - my $c_url_directory = 1 if ($current_url =~ m|/$|); - my $remove_slash = 1 if ($urlr =~ m|^\\$|); # back slash \ not a forward slash / - - ### is urlr a slash only ? - if ($urlr =~ m|^/$|) { # if slash only - $current_url .= "/"; - url("$current_url"); - return 0; - } - - ### remove slash ? - if ($remove_slash) { - substr($current_url,-1,1,''); - ### $current_url - url($current_url); - return 0; - } - - ### is the current url a directory? - if ($c_url_directory) { - $current_url .= "$urlr"; - my $c_p_url = parse_url($current_url); - ### $c_p_url - # if $urlr has '..' then normalize_path will not go beyond the last element - # which is why prefixing a '/' and then taking it away (parse_url doesnt have - # the forward / ) will result in expected behavior as host always end with '/' - $c_p_url->{path} = normalize_path("/" . $c_p_url->{path}); - if ($end_with_slash or $dot_only or $dot_2_only) { - $c_p_url->{path} .= "/"; # normalize path will remove it - } - substr($c_p_url->{path},0,1,''); - if ($c_p_url->{path} eq '/') { - delete $c_p_url->{path}; # dont want to ask for 'gemini://host.com//' - } - url(return_url($c_p_url)); - return 0; - } - - ### current url is not a directory, so should be fine to remove last item on path - # ^ some servers serve index page on 'dir' rather than 'dir/' :v annoying - # authors using servers like that will notice that the links on index page need to be - # carefully managed, because ALL clients (that handle links correctly) *will* mess up. - if (! $c_url_directory) { - my $c_p_url = parse_url($current_url); - ### $c_p_url - my $c_paths_url = split_url_path($c_p_url->{path}, 256); - ### $c_paths_url - pop(@$c_paths_url); - ### $c_paths_url - delete ($c_p_url->{path}); - for (@$c_paths_url) { - $c_p_url->{path} .= "$_/"; - } - ### $c_p_url - $c_p_url->{path} .= "$urlr"; - $c_p_url->{path} = normalize_path("/" . "$c_p_url->{path}"); - if ($end_with_slash or $dot_only or $dot_2_only) { - $c_p_url->{path} .= "/"; # normalize path will remove it - } - substr($c_p_url->{path},0,1,''); - if ($c_p_url->{path} eq '/') { - delete $c_p_url->{path}; # dont want to ask for 'gemini://host.com//' - } - ### $c_p_url - url(return_url($c_p_url)); - return 0; - } -} +#sub urlrelative { +# my ($urlr) = @_; +# if (! $urlr) { $urlr = ""} +# if (! $current_url) {show_to_user( "Relative movement impossible: no current URL.\n"); return 1;} +# my $end_with_slash = 1 if ($urlr =~ m|/$|); +# my $dot_only = 1 if ($urlr =~ m|^\.$|); +# my $dot_2_only = 1 if ($urlr =~ m|^\.\.$|); # since we are going up into a dir +# my $c_url_directory = 1 if ($current_url =~ m|/$|); +# my $remove_slash = 1 if ($urlr =~ m|^\\$|); # back slash \ not a forward slash / +# +# ### is urlr a slash only ? +# if ($urlr =~ m|^/$|) { # if slash only +# $current_url .= "/"; +# url("$current_url"); +# return 0; +# } +# +# ### remove slash ? +# if ($remove_slash) { +# substr($current_url,-1,1,''); +# ### $current_url +# url($current_url); +# return 0; +# } +# +# ### is the current url a directory? +# if ($c_url_directory) { +# $current_url .= "$urlr"; +# my $c_p_url = parse_url($current_url); +# ### $c_p_url +# # if $urlr has '..' then normalize_path will not go beyond the last element +# # which is why prefixing a '/' and then taking it away (parse_url doesnt have +# # the forward / ) will result in expected behavior as host always end with '/' +# $c_p_url->{path} = normalize_path("/" . $c_p_url->{path}); +# if ($end_with_slash or $dot_only or $dot_2_only) { +# $c_p_url->{path} .= "/"; # normalize path will remove it +# } +# substr($c_p_url->{path},0,1,''); +# if ($c_p_url->{path} eq '/') { +# delete $c_p_url->{path}; # dont want to ask for 'gemini://host.com//' +# } +# url(return_url($c_p_url)); +# return 0; +# } +# +# ### current url is not a directory, so should be fine to remove last item on path +# # ^ some servers serve index page on 'dir' rather than 'dir/' :v annoying +# # authors using servers like that will notice that the links on index page need to be +# # carefully managed, because ALL clients (that handle links correctly) *will* mess up. +# if (! $c_url_directory) { +# my $c_p_url = parse_url($current_url); +# ### $c_p_url +# my $c_paths_url = split_url_path($c_p_url->{path}, 256); +# ### $c_paths_url +# pop(@$c_paths_url); +# ### $c_paths_url +# delete ($c_p_url->{path}); +# for (@$c_paths_url) { +# $c_p_url->{path} .= "$_/"; +# } +# ### $c_p_url +# $c_p_url->{path} .= "$urlr"; +# $c_p_url->{path} = normalize_path("/" . "$c_p_url->{path}"); +# if ($end_with_slash or $dot_only or $dot_2_only) { +# $c_p_url->{path} .= "/"; # normalize path will remove it +# } +# substr($c_p_url->{path},0,1,''); +# if ($c_p_url->{path} eq '/') { +# delete $c_p_url->{path}; # dont want to ask for 'gemini://host.com//' +# } +# ### $c_p_url +# url(return_url($c_p_url)); +# return 0; +# } +#} sub return_url { my ($url) = @_; @@ -740,22 +616,22 @@ sub get_links { } } -sub hist { - my $hist; - my $counter = 1; - ### @history - for my $item (@history) { - ### $item - $hist .= "[$counter] ". colored("$$item[0]", 'underline') ." $$item[1]\n"; - $counter++; - } - if ($hist) { - print $OUT $hist; - } - else { - print $OUT "\n"; - } -} +#sub hist { +# my $hist; +# my $counter = 1; +# ### @history +# for my $item (@history) { +# ### $item +# $hist .= "[$counter] ". colored("$$item[0]", 'underline') ." $$item[1]\n"; +# $counter++; +# } +# if ($hist) { +# show_to_user( $hist); +# } +# else { +# show_to_user( "\n"); +# } +#} sub update_history { my ($history) = @_; @@ -770,10 +646,10 @@ sub links { $counter++; } if ($d) { - print $OUT $d; + show_to_user( $d); } else { - print $OUT "No links.\n"; + show_to_user( "No links.\n"); } } @@ -786,8 +662,8 @@ sub nav { ### $setting ### @_ if (! $n or $n !~ /\d+/) { - print $OUT "Try 'links', 'hist', or 'bookmarks' then 'navY X', where x is the number and Y. " . - "is nav mode.\n"; + #print $OUT "Try 'links', 'hist', or 'bookmarks' then 'navY X', where x is the number and Y. " . + #"is nav mode.\n"; return 1; } $n -= 1; @@ -802,7 +678,7 @@ sub nav { $link = $bookmarks[$n]; } else { - print $OUT "'" . ($n+1) ."' isn't available.\n"; + show_to_user( "'" . ($n+1) ."' isn't available.\n"); return 1; } access_resource($link); @@ -896,7 +772,7 @@ sub back { } } else { - print $OUT "No such history there."; + show_to_user( "No such history there."); } ### @history @@ -905,40 +781,38 @@ sub back { sub display { $t->delete('0.0', 'end'); - $t->insert('0.0', "@doc"); -# if ($config{pager_text_wrap_auto}) { -# my ($wc) = GetTerminalSize(); -# $wrapper->columns($wc); -# } -# if ($config{use_pager}) { -# ### opening IO Pager -# eval { -# # catch it or big files ( >1000 lines ) will load but the script itself dies for some reason -# local $SIG{PIPE} = sub { die }; -# IO::Pager::open(my $FH) or warn($!); -# for (@doc) { -# _pre_block($_); -# if ($pre_block) { -# print $FH $_; -# } -# else { -# print $FH $wrapper->wrap($_); -# } -# } -# close $FH; -# }; -# } -# else { -# for (@doc) { -# _pre_block($_); -# if ($pre_block) { -# print $OUT $_; -# } -# else { -# print $OUT $wrapper->wrap($_); -# } -# } -# } + my $counter = 0; + foreach my $line (@doc) { + _pre_block($line); + if ((substr($line,0,2)) eq '=>' and not $pre_block) { + $line =~ m/^=>[\s]*([\w\d\-\\\/\.\:\~\?\=\#]+)[\s]*(.+)?$/; + if ($2) { + $line = colored("[". ($counter+1) . _is_not_scheme_gemini($1) . "]",'underline') . " $2\n"; + } + else { + $line = colored("[" . ($counter+1) . _is_not_scheme_gemini($1) . "]",'underline') . " $1\n"; + } + $t->insert('end', "$line", "URL$counter"); + $counter++; + } + else { + $t->insert('end', "$line"); + } + } + #print Dumper($t->tagNames()); + for my $item ($t->tagNames()) { + if (substr($item,0,3) eq 'URL') { + $t->tagBind("$item", '<Any-Enter>'=> sub {shift->tagConfigure("$item",@bold)}); + $t->tagBind("$item", '<Any-Leave>'=> sub {shift->tagConfigure("$item",@normal)}); + $item =~ m/^URL(\d+)+$/; + my $number = $1; + $t->tagBind("$item", '<1>', sub {nav(0,($number+1))}); + } + } + # Author's note: ^ do not touch unless you know why I did what I did. + # Absolutely maddening. ... You'd think a while loop and incrementing + # $counter (after setting to 0) and doing "URL$counter" would work + # but actually that doesn't work at all, and I don't know why. } sub toggle { @@ -951,61 +825,7 @@ sub toggle { $t = 1; } if (! $_[1]) { - print $OUT "$t\n"; - } -} - -#sub textwrap { -# my ($c) = @_; -# if ($c and $c =~ m/^\d+$/) { -# $config{textwrap} = $c; -# $wrapper->columns($c); -# $config{pager_text_wrap_auto} = 0; -# } elsif ($c and $c eq 'auto') { -# $config{pager_text_wrap_auto} = 1; -# } -# else { -# if ($config{pager_text_wrap_auto}) { -# my ($c) = GetTerminalSize(); -# print("[AUTO] $c\n"); -# } -# else { -# print "$config{textwrap}\n"; -# } -# } -#} - -sub pager { - my ($p,@other) = @_; - ### @other - if ($p) { - $config{pager} = $p; - if ($other[0]) { - for (@other) { - $config{pager} .= " $_"; - } - } - print $OUT "save-config, and restart the program for change to take effect.\n"; - } - else { - print $OUT "$config{pager}\n"; - } -} - -sub pretty_links { - my $counter = 1; - for (@doc) { - _pre_block($_); - if ((substr($_,0,2)) eq '=>' and not $pre_block) { - $_ =~ m/^=>[\s]*([\w\d\-\\\/\.\:\~\?\=\#]+)[\s]*(.+)?$/; - if ($2) { - $_ = colored("[$counter" . _is_not_scheme_gemini($1) . "]",'underline') . " $2\n"; - } - else { - $_ = colored("[$counter" . _is_not_scheme_gemini($1) . "]",'underline') . " $1\n"; - } - $counter++; - } + show_to_user( "$t\n"); } } @@ -1049,7 +869,7 @@ sub value_number { my $numb = $_[1]; my $k = $_[2]; $v = $numb if ($numb =~ m/^\d*$/); - print $OUT "$k is now: $v\n"; + show_to_user( "$k is now: $v\n"); ### @_ } @@ -1065,24 +885,24 @@ sub cert_create { if (! -e "$xdg_data/certs") { mkdir("$xdg_data/certs"); } - print $OUT "What should the profile name be? "; + show_to_user( "What should the profile name be? "); chomp(my $input = <STDIN>); $input =~ tr|/|.|; if (-e "$xdg_data/certs/$input") { - print $OUT "Sorry, but that already exists.\n"; + show_to_user( "Sorry, but that already exists.\n"); } else { mkdir("$xdg_data/certs/$input"); - print $OUT "What should the commonName be? (it will be used to identify you easily) "; + show_to_user( "What should the commonName be? (it will be used to identify you easily) "); chomp(my $common_name = <STDIN>); my $expire; while (1) { - print $OUT "When should this expire? (1s, 1h, 1d, 1m, 1y, 0s (cancel)) "; + show_to_user( "When should this expire? (1s, 1h, 1d, 1m, 1y, 0s (cancel)) "); chomp($expire = <STDIN>); if ($expire =~ m/^(\d+)+(\w)$/) { if (lc $2 eq 's') { if ($1 == 0) { - print $OUT "Cancelling.\n"; + show_to_user( "Cancelling.\n"); umask($old_umask); return 1; } @@ -1131,20 +951,20 @@ sub cert_use { my $counter = 1; my @profiles; if (! -e "$xdg_data/certs") { - print $OUT "You need to create a cert first: 'cert-create'.\n"; + show_to_user( "You need to create a cert first: 'cert-create'.\n"); return 1; } for (read_dir("$xdg_data/certs")) { - print $OUT "[$counter] $_\n"; + show_to_user( "[$counter] $_\n"); push(@profiles, "$_"); $counter++; } if (! @profiles) { - print $OUT "You need to create a cert first: 'cert-create'.\n"; + show_to_user( "You need to create a cert first: 'cert-create'.\n"); return 1; } - print $OUT "Which profile? "; + show_to_user( "Which profile? "); chomp(my $input = <STDIN>); if ($input) { @@ -1157,71 +977,71 @@ sub cert_use { $key = "$xdg_data/certs/$profiles[$input-1]/key.pem"; }; if ($@) { - print $OUT "Something is wrong with the certificate/key. Will not use.\n$@"; + show_to_user( "Something is wrong with the certificate/key. Will not use.\n$@"); $cert = ""; $key = ""; } else { - print $OUT "Cert and Key loaded.\n"; + show_to_user( "Cert and Key loaded.\n"); toggle($use_cert); } } else { - print $OUT "Did not load anything.\n"; + show_to_user( "Did not load anything.\n"); } } else { - print $OUT "Unloading cert and key.\n"; + show_to_user( "Unloading cert and key.\n"); toggle($use_cert); } } sub cert_del { if (! -e "$xdg_data/certs") { - print $OUT "You need to create a cert first: 'cert-create'.\n"; + show_to_user( "You need to create a cert first: 'cert-create'.\n"); return 0; } my $counter = 1; my @profiles; for (read_dir("$xdg_data/certs")) { - print $OUT "[$counter] $_\n"; + show_to_user( "[$counter] $_\n"); push(@profiles, "$_"); $counter++; } if (! @profiles) { - print $OUT "You need to create a cert first: 'cert-create'.\n"; + show_to_user( "You need to create a cert first: 'cert-create'.\n"); return 0; } - print $OUT "Delete which profile? "; + show_to_user( "Delete which profile? "); chomp(my $input = <STDIN>); if ($input) { - print $OUT "Are you sure you want to delete $profiles[$input-1]/? y/N"; + show_to_user( "Are you sure you want to delete $profiles[$input-1]/? y/N"); chomp(my $yORn = <STDIN>); if (lc $yORn eq 'y') { unlink("$xdg_data/certs/$profiles[$input-1]/cert.pem", "$xdg_data/certs/$profiles[$input-1]/key.pem"); rmdir("$xdg_data/certs/$profiles[$input-1]"); if ($!) { - print $OUT "Unable to delete profile.\n$!\n"; + show_to_user( "Unable to delete profile.\n$!\n"); } else { - print $OUT "Profile '$profiles[$input-1]' succesfully deleted.\n"; + show_to_user( "Profile '$profiles[$input-1]' succesfully deleted.\n"); } } else { - print $OUT "Nothing is deleted.\n"; + show_to_user( "Nothing is deleted.\n"); } } else { - print $OUT "Nothing is deleted.\n"; + show_to_user( "Nothing is deleted.\n"); } } sub bookmarks { my $counter = 1; for (@bookmarks) { - print $OUT "[$counter] $_\n"; + show_to_user( "[$counter] $_\n"); $counter++; } } @@ -1230,13 +1050,13 @@ sub bookmark_del { my ($b) = @_; if ($b and $b =~ m/^\d+$/) { if ($bookmarks[$b-1]) { - print $OUT "Removing $bookmarks[$b-1]"; + show_to_user( "Removing $bookmarks[$b-1]"); splice(@bookmarks,$b-1,1); } ### @bookmarks } else { - print $OUT "Doing nothing."; + show_to_user( "Doing nothing."); } } @@ -1262,7 +1082,7 @@ sub load_config { if (-e "$xdg_config/config.toml") { ($config, $err) = from_toml(read_text("$xdg_config/config.toml")); unless ($config) { - print $OUT "Error parsing toml: $err\n"; + show_to_user( "Error parsing toml: $err\n"); } } ### $config |