App-Phoebe
view release on metacpan or search on metacpan
table code goes nuts and throws a gazillion warnings. I still
haven't fixed this, so for the time being, tables are simple no
longer handled.
- contrib/heap-dump.pl: New, in case you need to debug heap dumps of
the Phoebe process.
2.07
- Fixed serving of robots.txt in a virtual hosting environment;
ignoring query and fragment when deciding whether to serve the
default robots.txt.
- phoebe-ctl can export HTML.
2.02
- Handle international domain names: when you provide them with the
--host option, the address lookup happens using their punycode
representation, and URIs containing these punycode representations
of the international domain name are served correctly.
lib/App/Phoebe.pm view on Meta::CPAN
local $SIG{'ALRM'} = sub {
$log->error("Timeout processing $url");
};
alarm(10); # timeout
my $hosts = host_regex();
my $port = port($stream);
my $spaces = space_regex();
my $reserved = reserved_regex($stream);
$log->debug("Serving ($hosts)(?::$port)?");
$log->debug("Spaces $spaces");
my($scheme, $authority, $path, $query, $fragment) =
$url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
$log->info("Looking at $url");
my ($host, $space, $id, $n, $style, $filter);
if (run_extensions($stream, $url)) {
# config file goes first
} elsif (not $url) {
$log->debug("The URL is empty");
result($stream, "59", "URL expected");
} elsif (length($url) > 1024) {
$log->debug("The URL is too long");
lib/App/Phoebe.pm view on Meta::CPAN
sub is_upload {
my $stream = shift;
my $request = shift;
$log->info("Looking at $request");
my $hosts = host_regex();
my $spaces_regex = space_regex();
my $port = port($stream);
if ($request =~ m!^titan://($hosts)(?::$port)?!) {
my $host = $1;
my($scheme, $authority, $path, $query, $fragment) =
$request =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
if ($path =~ m!^(?:/($spaces_regex))?(?:/raw|/page|/file)?/([^/;=&]+(?:;\w+=[^;=&]+)+)!) {
my $space = $1;
my ($id, @params) = split(/[;=&]/, $2);
my $params = { map {decode_utf8(uri_unescape($_))} @params };
if (valid_params($stream, $host, $space, $id, $params)) {
return {
host => $host,
space => space($stream, $host, $space),
id => decode_utf8(uri_unescape($id)),
lib/App/Phoebe/Capsules.pm view on Meta::CPAN
capsule => $capsule,
id => $id,
params => \%params,
}
}
# valid_params printed a response and closed the stream
return;
}
$log->debug("Capsule upload with malformed titan URL");
if ($request =~ m!^titan://($hosts)(?::$port)?/$capsule_space/([^/?#;]+)/([^/?#;]+);([^?#]*)[?#]!) {
result($stream, "59", "The titan URL must not have a query or a fragment at the end");
} elsif ($request =~ m!^titan://($hosts)(?::$port)?/$capsule_space/([^/?#;]+)/([^/?#;]+)/!) {
result($stream, "59", "These capsules do not allow uploads for subdirectories");
} elsif ($request =~ m!^titan://($hosts)(?::$port)?/$capsule_space/([^/?#;]+)/([^/?#;]+)$!) {
result($stream, "59", "The titan URL is missing the parameters after a semikolon $1 $2 $3 $4");
} elsif ($request =~ m!^titan://($hosts)(?::$port)?/$capsule_space/([^/?#;]+)/?(;.*)$!) {
result($stream, "59", "The titan URL is missing the file name");
} elsif ($request =~ m!^titan://($hosts)(?::$port)?/$capsule_space/?$!) {
result($stream, "59", "The titan URL is missing the capsule name and the file name");
} else {
result($stream, "59", "The titan URL is malformed");
lib/App/Phoebe/Iapetus.pm view on Meta::CPAN
sub setup_iapetus {
my $stream = shift;
my $data = shift;
my $request = $data->{request};
$log->info("Looking at $request");
my $hosts = host_regex();
my $spaces_regex = space_regex();
my $port = port($stream);
if ($request =~ m!^iapetus://($hosts)(?::$port)?!) {
my $host = $1;
my($scheme, $authority, $path, $query, $fragment, $size) =
$request =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(\S*))?\s+(\d+)|;
if ($path =~ m!^(?:/($spaces_regex))?(?:/raw)?/([^/;=&]+)!) {
my ($space, $id) = ($1, $2);
return unless valid_id($stream, $host, $space, $id);
my $type = globs($id) || mime_type($id);
my $params = { size => $size, mime => $type };
return unless valid_mime_type($stream, $host, $space, $id, $params);
return unless valid_size($stream, $host, $space, $id, $params);
return unless valid_client_cert($stream, $host, $space, $id, $params);
$data->{upload} = {
lib/App/Phoebe/Oracle.pm view on Meta::CPAN
our $max_answers = 5;
If you want to notify Antenna whenever a new question has been asked:
use App::Phoebe qw($log);
use IO::Socket::SSL;
# a very simple Gemini client
sub query {
my $url = shift;
my($scheme, $authority, $path, $query, $fragment) =
$url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(\S*))?|;
my ($host, $port) = split(/:/, $authority);
my $socket = IO::Socket::SSL->new(
PeerHost => $host, PeerPort => $port||1965,
# don't verify the server certificate
SSL_verify_mode => SSL_VERIFY_NONE, );
$socket->print($url);
local $/ = undef; # slurp
return <$socket>;
}
script/gemini view on Meta::CPAN
my $iri = IRI->new(value => encode_utf8 $uri);
die "âš The URI '$uri' must use the gemini scheme\n" unless $iri->scheme and $iri->scheme eq 'gemini';
die "âš The URI '$uri' must have an authority\n" unless $iri->authority;
my $host = domain_to_ascii(decode_utf8 $iri->host);
my $port = $iri->port || 1965;
my $unsafe = "^A-Za-z0-9\-\._~%"; # the default + already encoded
my $path = uri_escape_utf8($iri->path, $unsafe . "/"); # path separator are safe
my $query = uri_escape_utf8($iri->query, $unsafe . "&;="); # parameter separators are safe
my $fragment = uri_escape_utf8($iri->fragment); # use the default
$uri = $iri->scheme . '://' . $host . ':' . $port;
$uri .= $path if $path;
$uri .= '?' . $query if $query;
$uri .= '#' . $fragment if $fragment;
warn "Contacting $host:$port" if $verbose;
# create client
Mojo::IOLoop->client({
address => $host,
port => $port,
tls => 1,
tls_cert => $cert,
tls_key => $key,
script/gemini-chat view on Meta::CPAN
decode_argv();
my ($uri) = @ARGV;
die "âš You must provide an URI\n" unless $uri;
my $iri = IRI->new(value => encode_utf8 $uri);
die "âš The URI '$uri' must use the gemini scheme\n" unless $iri->scheme and $iri->scheme eq 'gemini';
die "âš The URI '$uri' must have an authority\n" unless $iri->authority;
warn "âš Ignoring path '" . $iri->path . "'\n" if $iri->path;
warn "âš Ignoring fragment '" . $iri->fragment . "'\n" if $iri->fragment;
my $host = domain_to_ascii(decode_utf8 $iri->host);
my $port = $iri->port || 1965;
my $unsafe = "^A-Za-z0-9\-\._~"; # the default
my $path = uri_escape_utf8($iri->path, $unsafe . "/"); # path separator are safe
$uri = $iri->scheme . '://' . $host . ':' . $port;
$uri .= $path if $path;
# start read loop for saying stuff
script/ijirait view on Meta::CPAN
die "âš You must provide a URL, e.g. gemini://campaignwiki.org/play/ijirait\n" unless $url;
die "âš You must provide --cert_file, e.g. --cert_file=cert.pem\n" unless $cert;
die "âš You must provide --key_file, e.g. --key_file=key.pem\n" unless $key;
die "âš You must provide an existing --cert_file\n" unless -f $cert;
die "âš You must provide an existing --key_file\n" unless -f $key;
$stream = 1 if $url =~ /\/stream$/;
my $talk_url = "$url/type";
my($scheme, $authority, $path, $query, $fragment) =
$url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
die "âš The URL '$url' must use the gemini scheme\n" unless $scheme and $scheme eq 'gemini';
my ($host, $port) = split(/:/, $authority, 2);
$port //= 1965;
if ($stream) {
stream();
} else {
script/spartan view on Meta::CPAN
my $parser = Pod::Text->new();
$parser->parse_file($0);
exit;
}
# Regular arguments
my ($url) = @ARGV;
die "âš You must provide an URL\n" unless $url;
my($scheme, $authority, $path, $query, $fragment) =
$url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
die "âš The URL '$url' must use the spartan scheme\n" unless $scheme and $scheme eq 'spartan';
die "âš The URL '$url' must have an authority\n" unless $authority;
my ($host, $port) = split(/:/, $authority);
$port ||= 300;
$path ||= "/";
warn "Contacting $host:$port\n" if $verbose;
script/titan view on Meta::CPAN
$parser->parse_file($0);
exit;
}
# Remaining arguments
my ($url, @files) = @ARGV;
$token //= '';
die "âš You must provide an URL\n" unless $url;
my($scheme, $authority, $path, $query, $fragment) =
$url =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
die "âš The URL '$url' must use the titan scheme\n" unless $scheme and $scheme eq 'titan';
die "âš The URL '$url' must have an authority\n" unless $authority;
die "âš The URL '$url' must have a path\n" unless $path;
die "âš The URL '$url' must not have a query\n" if $query;
die "âš The URL '$url' must not have a fragment\n" if $fragment;
if (@files > 1) {
die "âš The URL '$url' must have a path that ends in a slash\n" if $path !~ /\/$/;
} elsif (not @files) {
die "âš The URL '$url' must have a path that does not end in a slash\n" if $path =~ /\/$/;
}
for my $file (@files) {
die "âš The file '$file' does not exist\n" unless -e $file;
die "âš The file '$file' cannot be read\n" unless -r $file;
t/oddmuse-wiki.pl view on Meta::CPAN
push(@Flags, 1);
$Fragment = '';
}
sub ApplyRules {
# locallinks: apply rules that create links depending on local config (incl. interlink!)
my ($text, $locallinks, $withanchors, $revision, @tags) = @_; # $revision is used for images
$text =~ s/\r\n/\n/g; # DOS to Unix
$text =~ s/\n+$//g; # No trailing paragraphs
return if $text eq ''; # allow the text '0'
local $Fragment = ''; # the clean HTML fragment not yet on @Blocks
local @Blocks = (); # the list of cached HTML blocks
local @Flags = (); # a list for each block, 1 = dirty, 0 = clean
Clean(join('', map { AddHtmlEnvironment($_) } @tags));
if ($OpenPageName and $PlainTextPages{$OpenPageName}) { # there should be no $PlainTextPages{''}
Clean(CloseHtmlEnvironments() . $q->pre($text));
} elsif (my ($type) = TextIsFile($text)) { # TODO? $type defined here??
Clean(CloseHtmlEnvironments() . $q->p(T('This page contains an uploaded file:'))
. $q->p(GetDownloadLink($OpenPageName, (substr($type, 0, 6) eq 'image/'), $revision))
. (length $Page{summary} > 0 ? $q->blockquote(QuoteHtml($Page{summary})) : $q->p(T('No summary was provided for this file.'))));
} else {
t/oddmuse-wiki.pl view on Meta::CPAN
$end2 ||= $start2;
$new = DiffHtmlMarkWords($new, $start2, $end2);
}
}
return (DiffAddPrefix($old, '< ', 'old'),
DiffAddPrefix($new, '> ', 'new'));
}
sub DiffHtmlMarkWords {
my ($text, $start, $end) = @_;
my @fragments = split(/(\s+|\b)/, $text);
splice(@fragments, 2 * ($start - 1), 0, '<strong class="changes">');
splice(@fragments, 2 * $end, 0, '</strong>');
my $result = join('', @fragments);
$result =~ s!&<(/?)strong([^>]*)>(amp|[gl]t);!<$1strong$2>&$3;!g;
$result =~ s!&(amp|[gl]t)<(/?)strong([^>]*)>;!&$1;<$2strong$3>!g;
return $result;
}
sub DiffStripPrefix {
my $str = shift;
$str =~ s/^&[lg]t; //gm;
return $str;
}
( run in 1.715 second using v1.01-cache-2.11-cpan-b16cb0d3907 )