#!/usr/bin/perl # this is a gemini client use strict; use warnings; #use diagnostics; #use utf8; #use bytes; use feature qw(refaliasing); no warnings qw(experimental::refaliasing); our $VERSION = 'v0.0.27'; # TODO: # back() only works once; should fix this # 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::ANSIColor; # Core use Path::Naive qw(normalize_path); # CPAN use Text::ParseWords; # Core use Term::ReadLine; # CPAN use Smart::Comments; # CPAN use URI::Encode qw(uri_encode); # CPAN use IO::Socket::SSL::Utils; # CPAN use File::Slurper qw(read_dir); # CPAN # 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 my $wrapper = Text::Wrapper->new(columns=>70, body_start=>''); $ENV{PAGER} = 'most'; #$ENV{PAGER} = 'less -r'; my $use_pager = 1; my $pager_text_wrap_auto = 1; my $doc_out = 1; # display doc for human consumption? my @doc; my @links; my $current_url = ""; my @history; my $prompt = ""; my $pretty_links = 1; my $pretty_headers = 1; my $pre_block = 0; my @status_code; my $status_code1; my $status_code2; my $auto_redirect = 2; my $auto_redirect_count = 0; my $sleep; my $timeout = 3; my $use_cert = 0; my $cert; my $key; my $term=new Term::ReadLine "hmm, what goes here?"; my $OUT = $term->OUT || \*STDOUT; 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\'.'], '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.' ], '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($use_pager) }, 'This toggles pager use. 1 = use pager, 0 = stdout.' ], 'pretty_links' => [sub { toggle($pretty_links) }, "0 = do nothing, 1 = pretty."], 'pretty_headers' => [sub { toggle($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]) }, "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. (cmds to see commands)'], 'ver' => [sub {print $OUT "$VERSION\n"}, "Returns the version ($VERSION)"], 'exit' => [sub {exit 0;}, "This exits the program with a status code of 0."], 'autoredirection' => [sub { value_number($auto_redirect,$_[0],'autoredirect') }, "The amount of times this program is allowed to auto redirect. 0 = none."], 'timeout' => [sub { value_number($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." ], ); 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 "Press to see available commands.\n"; while ( defined ($_ = $term->readline($prompt)) ) { if ($_) { my ($command, $detail) = split(/\s/, $_); do_command(\$command, \$detail); } $prompt = "$current_url > "; } sub do_command { # referenced command, referenced arg my ($rCmd, $rArg) = @_; # ## @_ # 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); } # 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 url { my ($url) = @_; ### $url if (!$url) { print("Example: [gemini://]capsule.com/\n"); return 1;} if (! has_scheme($url) ) { $url = "gemini://$url"; } eval { $url = parse_url($url); }; if ($@) { print $OUT "$@\n"; return 1; } ### $url if (! $url->{port} or $url->{port} eq 0) { $url->{port} = '1965'; } my $cl; if ($use_cert and $cert and $key) { $cl = IO::Socket::SSL->new( PeerHost => "$url->{host}", PeerPort => "$url->{port}", SSL_verify_mode => SSL_VERIFY_NONE, SSL_verifycn_name => "$url->{host}", SSL_version => '!SSLv2:!SSLv3:!TLSv1:!TLSv1_1', SSL_fast_shutdown => 1, SSL_cert_file => "$cert", SSL_key_file => "$key", Timeout => 2, ); } else { $cl = IO::Socket::SSL->new( PeerHost => "$url->{host}", PeerPort => "$url->{port}", SSL_verify_mode => SSL_VERIFY_NONE, SSL_verifycn_name => "$url->{host}", SSL_version => '!SSLv2:!SSLv3:!TLSv1:!TLSv1_1', SSL_fast_shutdown => 1, Timeout => 2, ); } if ($cl) { $current_url = return_url($url); ### $current_url ### $url undef(@doc); eval { local $SIG{ALRM} = sub {close ($cl); unshift(@doc,""); die "TIMEOUT";}; alarm $timeout; # gemini spec: # is an absolute path print $cl "$current_url\r\n"; @doc = <$cl>; close($cl); # if this isnt here, the kernel will have to clean up unused ports alarm 0; }; if ($@) { print $OUT "Timed out after $timeout seconds - server is taking too long.\n"; update_history( ["$current_url", "timed out"] ); ### @doc } else { follow_status_code(); } } else { print $OUT "error=$!, ssl_error=$SSL_ERROR\n"; } } sub follow_status_code { return 1 if (!@doc); @status_code = split(' ', $doc[0]); $status_code1 = substr($doc[0],0,1); $status_code2 = substr($doc[0],1,1); update_history( ["$current_url", "$status_code1$status_code2"] ); my $bad_code = "The server sent an invalid status code, not defined by gemini specifications.\n@doc"; if ($status_code1 == 2) { # 2 will probably be the most common server reply if ($status_code2 == 0) { shift(@doc); # user probably doesn't want to see the 20 */* every time # at some point deal with image/* and other media get_links(); pretty_links() if ($pretty_links); pretty_headers() if ($pretty_headers); if ($doc_out) { display(); } } else { print $OUT $bad_code; } } elsif ($status_code1 == 1) { if ($status_code2 == 0) { print $OUT "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; } else { print $bad_code; print $OUT "\nPresumably, the server wants you to type something:\n"; } chomp(my $input = ); $input = uri_encode($input); 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$/); if ($auto_redirect) { $auto_redirect_count++; if ($auto_redirect_count < $auto_redirect) { print $OUT "Redirection...\n"; ### @status_code access_resource($status_code[1]); # redirection can be './hello.gmi' } else { print $OUT "Reached limit for auto redirection.\n@doc"; } } else { print $OUT "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"; } elsif ($status_code2 == 1) { print $OUT "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"; } elsif ($status_code2 == 3) { print $OUT "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" . "Reconnecting after $sleep seconds\n" . "Press 'ctrl-C' to cancel sleep\n" . "@doc\n"; eval { local $SIG{INT} = sub { die "Cancelling Sleep!\n" }; sleep ($sleep); # give the server an extra second url($current_url); } } 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"; } undef($sleep); } else { print $bad_code; } } elsif ($status_code1 == 5) { if ($status_code2 == 0) { print $OUT "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"; } elsif ($status_code2 == 2) { print $OUT "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"; } elsif ($status_code2 == 9) { print $OUT "Bad Request. The server is unable to parse our request.\n@doc"; } else { print $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"; } elsif ($status_code2 == 1) { print $OUT "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"; } else { print $OUT $bad_code; } } else { print $OUT $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 return_url { 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); return $url_string; } sub get_links { undef(@links); #for my $line (split('\n', $doc)) { for (@doc) { #if ($line =~ m/^=>[\s]*([\w\d\-\\\/\.\:\~\?\=\#]+)[\s]*(.+)?$/gm) { _pre_block($_); if ($_ =~ m/^=>[\s]*([\w\d\-\\\/\.\:\~\?\=\#]+)[\s]*(.+)?$/gm and not $pre_block) { if ($2) { push(@links, ["$1", "$2"]); } else { push(@links, ["$1", "$1"]); } } } } sub hist { my $hist; my $counter = 1; for my $item (@history) { $hist .= "[$counter] ". colored("$$item[0]", 'underline') ." $$item[1]\n"; $counter++; } if ($hist) { print $OUT $hist; } else { print $OUT "\n"; } } sub update_history { my ($history) = @_; push(@history, $history); } sub links { my $d; my $counter = 1; for my $item (@links) { $d .= "[$counter] ". colored($$item[0], 'underline') . " $$item[1]\n"; $counter++; } if ($d) { print $OUT $d; } else { print $OUT "No links.\n"; } } sub nav { # Setting 0: from links # Setting 1: from history my ($setting,$n) = @_; ### $n ### $setting ### @_ if (! $n or $n !~ /\d+/) { print $OUT "Try 'links' or 'hist' then 'nav x', where x is the number.\n"; return 1; } $n -= 1; my $link; if ($setting == 0 and @links and exists $links[$n][0]) { $link = $links[$n][0]; } elsif ($setting == 1 and @history and exists $history[$n][0]) { $link = $history[$n][0]; } else { print $OUT "'" . ($n+1) ."' isn't available.\n"; return 1; } access_resource($link); } sub access_resource { my ($link) = @_; # This implies it is valid fqdn if (has_scheme($link)) { url("$link"); } elsif (substr($link,0,2) eq '//') { # technically valid url("gemini:$link"); } else { my $c_url = parse_url($current_url); my $end_with_slash = 1 if ($link =~ m|.*/$|); my $begin_with_slash = 1 if ($link =~ m|^/.*|); ### absolute location ? if ($begin_with_slash) { delete($c_url->{path}); $c_url->{path} = $link; #if ($end_with_slash){ # $c_url->{path} .= "/"; #} substr($c_url->{path},0,1,''); url(return_url($c_url)); return 0; } ### current url is a directory ? if ($current_url =~ m|.*/$|) { $current_url .= $link; #if ($end_with_slash) { # $current_url .= "/"; #} url(return_url($current_url)); return 0; } else { ### current url must NOT be a directory my $d; if ($c_url->{path}) { my $cp_url = split_url_path($c_url->{path}, 256); pop(@$cp_url); for (@$cp_url) { $d .= "$_/"; } } $d .= $link; $c_url->{path} = normalize_path($d); if ($end_with_slash) { $c_url->{path} .= "/"; } url(return_url($c_url)); return 0; } } } sub has_scheme { return ($_[0] =~ m|^.*(://)|); } sub root { my $new_url = parse_url($current_url); url("$new_url->{scheme}://$new_url->{host}/"); } sub back { my ($display) = @_; ### @_ ### $display my $dok_out = $doc_out; $doc_out = 0 if ($display == 1); if (@history >= 2) { url("$history[-2][0]"); } else { print $OUT "No such history there."; } ### @history $doc_out = $dok_out if ($display == 1); } sub display { if ($pager_text_wrap_auto) { my ($wc) = GetTerminalSize(); $wrapper->columns($wc); } my $doc; for (@doc) { $doc .= $_; } if ($use_pager) { IO::Pager::open(my $FH) or warn($!); #print $FH $wrapper->wrap($doc); print $FH $wrapper->wrap($doc); } else { #print($wrapper->wrap($doc)); print $OUT $wrapper->wrap($doc); } } sub toggle { # refaliasing \my $t = \$_[0]; if ($t == 1) { $t = 0; } else { $t = 1; } if (! $_[1]) { print $OUT "$t\n"; } } sub textwrap { my ($c) = @_; if ($c and $c =~ m/^\d+$/) { $wrapper->columns($c); $pager_text_wrap_auto = 0; } elsif ($c and $c eq 'auto') { $pager_text_wrap_auto = 1; } else { if ($pager_text_wrap_auto) { my ($c) = GetTerminalSize(); print("[AUTO] $c\n"); } else { print("$wrapper->{columns}\n"); } } } sub pager { my ($p) = @_; if ($p) { $ENV{pager} = $p; 0; } else { print("$ENV{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++; } } } sub pretty_headers { for (@doc) { _pre_block($_); if ((substr($_,0,3)) eq '###' and not $pre_block) { $_ =~ s/^###[\s]*(.*)$/colored("$1",'underline')/e; } if ((substr($_,0,2)) eq '##' and not $pre_block) { $_ =~ s/^##[\s]*(.*)$/colored("$1",'bold')/e; } if ((substr($_,0,1)) eq '#' and not $pre_block) { $_ =~ s/^#[\s]*(.*)$/colored("$1",'bold', 'underline')/e; } } } sub _is_not_scheme_gemini { ### @_ my ($thing) = $_[0]; if (has_scheme($thing)) { $_[0] =~ m|(.*)://.*|; if ($1 ne 'gemini') { return " $1"; } } return ''; } sub _pre_block { if (substr($_[0],0,3) eq '```') { toggle($pre_block,1); } } sub value_number { # refaliasing \my $v = \$_[0]; my $numb = $_[1]; my $k = $_[2]; $v = $numb if ($numb =~ m/^\d*$/); print $OUT "$k is now: $v\n"; ### @_ } sub clear_query { return 1 if (!$current_url); my @url = split('\?', $current_url); $current_url = $url[0]; } sub cert_create { # this should create certs somewhere more optimal, rather than the working directory my $old_umask = umask(077); if (! -e './certs') { mkdir('./certs'); } print $OUT "What should the profile name be? "; chomp(my $input = ); $input =~ tr|/|.|; if (-e "./certs/$input") { print $OUT "Sorry, but that already exists.\n"; } else { mkdir("./certs/$input"); print $OUT "What should the commonName be? (it will be used to identify you easily) "; chomp(my $common_name = ); #print $OUT "When should this expire (in seconds ('31536000' = 1 year))? "; my $expire; while (1) { print $OUT "When should this expire? (1s, 1h, 1d, 1m, 1y, 0s (cancel)) "; chomp($expire = ); if ($expire =~ m/^(\d+)+(\w)$/) { if (lc $2 eq 's') { if ($1 == 0) { print $OUT "Cancelling.\n"; umask($old_umask); return 1; } else { $expire = $1 + time(); } } elsif (lc $2 eq 'h') { $expire = ($1*3600) + time(); # 3600 seconds in an hour } elsif (lc $2 eq 'd') { $expire = ($1*86400) + time(); # 86400 seconds in a day } elsif (lc $2 eq 'm') { $expire = ($1*2592000) + time(); # 2592000 seconds in 30 days (month) } elsif (lc $2 eq 'y') { $expire = ($1*31536000) + time(); # 31536000 seconds in 365 days (year) } else { next; } } else { next; } last; } my $not_before = time(); ### $expire ### $not_before my %cert = ( 'subject' => { 'commonName' => "$common_name", }, 'not_before' => $not_before, 'not_after' => $expire, ); my ($cert, $key) = CERT_create(%cert); PEM_cert2file($cert,"./certs/$input/cert.pem"); PEM_key2file($key,"./certs/$input/key.pem"); CERT_free($cert); KEY_free($key); } umask($old_umask); } sub cert_use { if (! $use_cert) { my $counter = 1; my @profiles; # this should read dirs from a more optimal location, rather than working directory if (! -e './certs') { print $OUT "You need to create a cert first: 'cert-create'.\n"; return 1; } for (read_dir('./certs')) { print $OUT "[$counter] $_\n"; push(@profiles, "$_"); $counter++; } if (! @profiles) { print $OUT "You need to create a cert first: 'cert-create'.\n"; return 1; } print $OUT "Which profile? "; chomp(my $input = ); if ($input) { print $OUT "Loading 'certs/$profiles[$input-1]/cert.pem' and 'certs/$profiles[$input-1]/key.pem'\n"; eval { $cert = PEM_file2cert("certs/$profiles[$input-1]/cert.pem"); $key = PEM_file2key("certs/$profiles[$input-1]/key.pem"); CERT_free($cert); KEY_free($key); $cert = "certs/$profiles[$input-1]/cert.pem"; $key = "certs/$profiles[$input-1]/key.pem"; }; if ($@) { print $OUT "Something is wrong with the certificate/key. Will not use.\n$@"; $cert = ""; $key = ""; } else { print $OUT "Cert and Key loaded.\n"; toggle($use_cert); } } else { print $OUT "Did not load anything.\n"; } } else { print $OUT "Unloading cert and key.\n"; toggle($use_cert); } } sub cert_del { # cert dir should be in a more optimal place, not working directory. if (! -e './certs') { print $OUT "You have no certs/ directory.\n"; return 0; } my $counter = 1; my @profiles; for (read_dir('./certs')) { print $OUT "[$counter] $_\n"; push(@profiles, "$_"); $counter++; } if (! @profiles) { print $OUT "You need to create a cert first: 'cert-create'.\n"; return 1; } print $OUT "Delete which profile? "; chomp(my $input = ); if ($input) { print $OUT "Are you sure you want to delete certs/$profiles[$input-1]/? y/N\n"; chomp(my $yORn = ); if (lc $yORn eq 'y') { unlink("./certs/$profiles[$input-1]/cert.pem","./certs/$profiles[$input-1]/key.pem"); rmdir("./certs/$profiles[$input-1]"); if ($!) { print $OUT "Unable to delete profile.\n$!\n"; } else { print $OUT "Profile '$profiles[$input-1]' succesfully deleted.\n"; } } else { print $OUT "Nothing is deleted.\n"; } } else { print $OUT "Nothing is deleted.\n"; } }