$_
" for @lines; $body .= "\n$debug" if $Dev and $debug; say "
$code" . " after output!"; } Alert($html, $debug); exit; } BEGIN { require Time::HiRes; our $Time = [Time::HiRes::gettimeofday()]; push @INC, '.'; # user request our $Dev = $ENV{HTTP_HOST} =~ /\bdev\./; } our $Request //= decode_utf8($ENV{PATH_INFO} =~ s{^/}{}r); our $style; $header{content_type} = 'text/html; charset=utf-8'; sub stylesheet { my ($avail) = @_; my @avail = ref $avail eq 'ARRAY' ? @{$avail} : $avail or return; my %styles = map {$_ => $_} @avail; if (defined( my $setstyle = $get{style} )) { $style = $styles{ $setstyle }; eval { require CGI::Cookie; my $cookie = CGI::Cookie->new( -name => 'style', -value => $setstyle || '', -path => '/', # site-wide -expires => $setstyle ? '+5y' : '-1d', ) or die "empty object returned\n"; AddCookie($cookie->as_string); } or warn "Unable to create style cookie: $@"; } $style ||= exists $cookie{style} && $styles{ $cookie{style} } || $avail[0]; return map { sprintf( '', $_ eq $style ? 'stylesheet' : 'alternate stylesheet', "/$_.css?1.18", $_ ) } @avail; } sub checkmodified { my $lastmod = 0; for (@_) { my $mod = stat $_ or next; $mod = $mod->mtime or next; $lastmod = $mod if $mod gt $lastmod; } for ($ENV{HTTP_IF_MODIFIED_SINCE} || ()) { next if str2time($_) < $lastmod; $header{status} = '304 Same old'; exit; } $header{'Last-Modified'} = time2str($lastmod); } sub Data { my ($filename) = @_; my @data = eval { open my $cache, '<:raw', "data/$filename.json" or return do "./$filename.inc.pl"; # silent fallback to original code require JSON; local $/; # slurp return JSON::decode_json(readline $cache); }; if ($@ or !@data or !$data[0]) { die ['Table data not found', $@ || $!]; } if (@data == 1 and ref $data[0] eq 'HASH' and not %{$data[0]}) { die ['Table data missing']; } return wantarray ? @data : $data[0]; # list compatibility like do does } sub Html { my ($meta) = @_; unless ($meta->{nocache}) { # announce and check data modification checkmodified( $ENV{SCRIPT_FILENAME}, (grep { /\bShiar_/ } values %INC), $meta->{data} ? @{ $meta->{data} } : (), ); $header{'Cache-Control'} = 'max-age='.(24*60*60); } # default fallbacks $meta->{stylesheet} ||= [qw( light dark circus mono red )]; $meta->{charset} ||= 'utf-8'; $meta->{lang} ||= 'en'; # convert options to arrays ref $_ eq 'ARRAY' or $_ = [$_] for grep {$_} $meta->{raw}, $meta->{description}, $meta->{keywords}; # document headers before output $header{content_type} = "text/html; charset=$meta->{charset}" unless $PLP::sentheaders; exit if $ENV{REQUEST_METHOD} eq 'HEAD'; unshift @{ $meta->{raw} }, stylesheet($meta->{stylesheet}); push @{ $meta->{raw} }, ( '', ); if (my $img = $meta->{image}) { my $proto = sprintf('http%s://', !!$ENV{HTTPS} && 's'); my $url = "$proto$ENV{HTTP_HOST}/$img"; push @{ $meta->{raw} }, ( qq(), ); } my ($file) = $ENV{SCRIPT_FILENAME} =~ m{ ([^/]+) \.plp$ }x; $meta->{canonical} //= "/$file" . ($Request ne '' && "/$Request"); if (my $url = $meta->{canonical}) { $url = "https://sheet.shiar.nl$url"; push @{ $meta->{raw} }, qq(); } PLP_START { # leading output say ''; say qq(); say ''; say ''; say sprintf '', $_ for $header{content_type}; say sprintf '
beta
', join('; ', 'position: fixed', 'right: 1em', 'opacity: .5', 'border: 1ex solid red', 'border-width: 1ex 0', 'z-index: 1', 'background: inherit', ) if $Dev; }; # prepare trailing output PLP_END { print <<"EOT"; '; say ''; say ''; }; } BEGIN { $PLP::ERROR = sub { my ($message, $html) = @_; if (ref $message) { warn join ': ', @{$message}; $html = shift @{$message}; } else { warn $message; $message = []; } unless ($PLP::sentheaders) { Html({nocache => 1}); say '