use Exporter;
-our $VERSION = '1.1.3';
+our $VERSION = '1.1.4';
our @ISA = qw(Exporter);
our @EXPORT = ();
our @EXPORT_OK = (
'opendir_encoded', 'readdir_decoded', 'env_pwd_decoded',
'_x_encoded', 'stat_encoded',
'unlink_encoded', 'rename_encoded', 'copy_encoded',
- 'open_encoded'
+ 'open_encoded',
+ 'failpage',
+ 'fail_method', 'fail_content_type', 'fail_open_file', 'fail_attachment', 'fail_500',
+ 'redirect'
);
return %data;
}
+
+#####################################
+## HTTP ERROR PAGE & REDIRECTION ##
+#####################################
+
+# Function to return an error page
+# arguments: 1 - header fields, 2 - page title, 3 - error message, 4 method
+sub failpage {
+ (my $header, my $title, my $message, my $method, my $hyperlink) = @_;
+
+ if (ref($header)) {
+ foreach my $header_name (keys %$header) {
+ print http_header_line($header_name, $header->{$header_name});
+ }
+ }
+ elsif($header ne '') {
+ print $header;
+ }
+ if($method eq 'HEAD') {
+ print "\n";
+ return;
+ }
+ my $_title = html_entity_encode_dec($title , 1);
+ my $_message = html_entity_encode_dec($message , 1);
+ my $_hyperlink = html_entity_encode_dec($hyperlink, 1);
+
+ print "Content-type: text/html; charset=UTF-8\n\n";
+
+ print '<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN" "">'."\n";
+ print ' <html lang="en">'."\n";
+ print ' <head>'."\n";
+ print ' <meta http-equiv="Content-type" content="text/html; charset=UTF-8">'."\n";
+ if ($title ne '') {
+ print ' <title>'.$_title.'</title>'."\n";
+ }
+ print ' </head>'."\n";
+ print ' <body>'."\n";
+ if ($title ne '') {
+ print ' <h1>'.$_title.'</h1>'."\n";
+ }
+ if (($message ne '') || ($hyperlink ne '')) {
+ print " <p>\n";
+ if ($message ne '') {
+ print ' '.$_message.($hyperlink ne '' ? '<br>' : '')."\n";
+ }
+ if ($hyperlink ne '') {
+ print ' <a href="'.$_hyperlink.'">'.$_hyperlink."</a>\n";
+ }
+ print " </p>\n";
+ }
+ print ' </body>'."\n";
+ print '</html>'."\n";
+}
+
+sub fail_method {
+ (my $method, my $allowed) = @_;
+
+ my $status = http_status(HTTP_STATUS->{'method_not_allowed'});
+ my $header =
+ http_header_line('status', $status) .
+ http_header_allow($allowed);
+
+ return failpage(
+ $header,
+ $status,
+ "The interface does not support the $method method.",
+ $method
+ );
+}
+
+sub fail_content_type
+{
+ (my $method, my $content_type) = @_;
+
+ my $status = http_status(HTTP_STATUS->{'unsupported_media_type'});
+ my $header = http_header_line('status', $status);
+
+ return failpage(
+ $header,
+ $status,
+ "Unsupported Content-type: $content_type.",
+ $method
+ );
+}
+
+sub fail_open_file
+{
+ (my $method, my $type, my $path) = @_;
+
+ my $status = http_status(HTTP_STATUS->{'not_found'});
+ my $header = http_header_line('status', $status);
+
+ return failpage(
+ $header,
+ $status,
+ "Can't open ".
+ ($type ne '' ? $type : 'file').
+ ($path ne '' ? ': "'.$path.'"' : '').
+ '.',
+ $method
+ );
+}
+
+sub fail_attachment
+{
+ (my $method, my $ID) = @_;
+
+ my $status = http_status(HTTP_STATUS->{'not_found'});
+ my $header = http_header_line('status', $status);
+
+ return failpage(
+ $header,
+ $status,
+ "Attachment $ID not found.",
+ $method
+ );
+}
+
+sub fail_500
+{
+ (my $method, my $text) = @_;
+
+ my $status = http_status(HTTP_STATUS->{'internal_server_error'});
+ my $header = http_header_line('status', $status);
+
+ return failpage(
+ $header,
+ $status,
+ $text,
+ $method
+ );
+}
+
+sub redirect
+{
+ (my $method, my $uri, my $code) = @_;
+ my $header;
+ my $status;
+ if ($code eq '') {
+ $code = HTTP_STATUS->{'found'};
+ }
+ # https://insanecoding.blogspot.com/2014/02/http-308-incompetence-expected.html
+ # 301 Moved Permanently
+ # 302 Found
+ # 303 See Other
+ # 307 Temporary Redirect
+ # 308 Permanent Redirect
+ $status = http_status($code);
+ $header = http_header_line('status', $status);
+ $header .= http_header_location($uri);
+
+ return failpage(
+ $header,
+ $status,
+ '',
+ $method,
+ $uri
+ );
+}
+
+
###########
## URL ##
###########
bicyclesonthemoon.info / projects / botm / common-perl / commitdiff