use Exporter;
-our $VERSION = '1.1.0';
+our $VERSION = '1.1.1';
our @ISA = qw(Exporter);
our @EXPORT = ();
our @EXPORT_OK = (
'read_data_file', 'write_data_file', 'write_postdata_file',
'read_list_file', 'write_list_file',
'read_header_file', 'read_header_env',
+ 'HTTP_STATUS', 'http_status', 'http_header_line',
+ 'http_header_status', 'http_header_allow', 'http_header_location', 'http_header_content_length', 'http_header_content_disposition',
'url_encode', 'url_decode',
'url_query_encode', 'url_query_decode',
'split_url', 'join_url', 'merge_url',
# https://tools.ietf.org/html/rfc2616#section-4.2
+# http://www.iana.org/assignments/http-status-codes/http-status-codes.xhtml
+use constant HTTP_STATUS => {
+ 100 => 'Continue',
+ 101 => 'Switching Protocols',
+ 102 => 'Processing',
+ 103 => 'Early Hints',
+
+ 200 => 'OK',
+ 201 => 'Created',
+ 202 => 'Accepted',
+ 203 => 'Non-Authoritative Information',
+ 204 => 'No Content',
+ 205 => 'Reset Content',
+ 206 => 'Partial Content',
+ 207 => 'Multi-Status',
+ 208 => 'Already Reported',
+ 226 => 'IM Used',
+
+ 300 => 'Multiple Choices',
+ 301 => 'Moved Permanently',
+ 302 => 'Found',
+ 303 => 'See Other',
+ 304 => 'Not Modified',
+ 305 => 'Use Proxy',
+ 306 => '(Unused)',
+ 307 => 'Temporary Redirect',
+ 308 => 'Permanent Redirect',
+
+ 400 => 'Bad Request',
+ 401 => 'Unauthorized',
+ 402 => 'Payment Required',
+ 403 => 'Forbidden',
+ 404 => 'Not Found',
+ 405 => 'Method Not Allowed',
+ 406 => 'Not Acceptable',
+ 407 => 'Proxy Authentication Required',
+ 408 => 'Request Timeout',
+ 409 => 'Conflict',
+ 410 => 'Gone',
+ 411 => 'Length Required',
+ 412 => 'Precondition Failed',
+ 413 => 'Content Too Large',
+ 414 => 'URI Too Long',
+ 415 => 'Unsupported Media Type',
+ 416 => 'Range Not Satisfiable',
+ 417 => 'Expectation Failed',
+ 418 => '(Unused)',
+ 421 => 'Misdirected Request',
+ 422 => 'Unprocessable Content',
+ 423 => 'Locked',
+ 424 => 'Failed Dependency',
+ 425 => 'Too Early',
+ 426 => 'Upgrade Required',
+ 428 => 'Precondition Required',
+ 429 => 'Too Many Requests',
+ 431 => 'Request Header Fields Too Large',
+ 451 => 'Unavailable For Legal Reasons',
+
+ 500 => 'Internal Server Error',
+ 501 => 'Not Implemented',
+ 502 => 'Bad Gateway',
+ 503 => 'Service Unavailable',
+ 504 => 'Gateway Timeout',
+ 505 => 'HTTP Version Not Supported',
+ 506 => 'Variant Also Negotiates',
+ 507 => 'Insufficient Storage',
+ 508 => 'Loop Detected',
+ 509 => 'Unassigned',
+ 510 => 'Not Extended',
+ 511 => 'Network Authentication Required',
+
+ 100 => 'Continue',
+ 101 => 'Switching Protocols',
+ 102 => 'Processing',
+ 103 => 'Early Hints',
+
+ 'ok' => 200,
+ 'created' => 201,
+ 'accepted' => 202,
+ 'non_authoritative_information' => 203,
+ 'no_content' => 204,
+ 'reset_content' => 205,
+ 'partial_content' => 206,
+ 'multi_status' => 207,
+ 'already_reported' => 208,
+ 'im_used' => 209,
+
+ 'multiple_choices' => 300,
+ 'moved_permanently' => 301,
+ 'found' => 302,
+ 'see_other' => 303,
+ 'not_modified' => 304,
+ 'use_proxy' => 305,
+ 'temporary_redirect' => 307,
+ 'permanent_redirect' => 308,
+
+ 'bad_request' => 400,
+ 'unauthorized' => 401,
+ 'payment_required' => 402,
+ 'forbidden' => 403,
+ 'not_found' => 404,
+ 'method_not_allowed' => 405,
+ 'not_acceptable' => 406,
+ 'proxy_authentication_required' => 407,
+ 'request_timeout' => 408,
+ 'conflict' => 409,
+ 'gone' => 410,
+ 'length_required' => 411,
+ 'precondition_failed' => 412,
+ 'content_too_large' => 413,
+ 'uri_too_long' => 414,
+ 'unsupported_media_type' => 415,
+ 'range_not_satisfiable' => 416,
+ 'expectation_failed' => 417,
+ 'misdirected_request' => 421,
+ 'unprocessable_content' => 422,
+ 'locked' => 423,
+ 'failed_dependency' => 424,
+ 'too_early' => 425,
+ 'upgrade_required' => 426,
+ 'precondition_required' => 428,
+ 'too_many_requests' => 429,
+ 'request_header_fields_too_large' => 431,
+ 'unavailable_for_legal_reasons' => 451,
+
+ 'internal_server_error' => 500,
+ 'not_implemented' => 501,
+ 'bad_gateway' => 502,
+ 'service_unavailable' => 503,
+ 'gateway_timeout' => 504,
+ 'http_version_not_supported' => 505,
+ 'variant_also-negotiates' => 506,
+ 'insufficient _torage' => 507,
+ 'loop_detected' => 508,
+ 'unassigned' => 509,
+ 'not_extended' => 510,
+ 'network_authentication required' => 511,
+
+};
+
+sub http_header_line {
+ (my $name, my $value, my $single_line) = @_;
+ if (
+ ($name !~ /^[\x21\x23-\x27\x2a\x2b\x2d\x2e\x30-\x39\x3d\x41-\x5a\x5e-\x7a\x7c\x7e]+$/s) ||
+ ($value !~ /^([^\x00-\x1f\x7f]|((\r?\n)?[ \t]))*$/s)
+ ) {
+ # name: 'token'
+ # value: 'field-value' (a bit complicated but when taken together,
+ # all *TEXT is allowed (we're not checking correct value, just if it doesn't break.))
+ return '';
+ }
+
+ $name = lc($name);
+ $name =~ s/^([a-z])/uc($1)/es;
+ $name =~ s/_([a-z])/'-'.uc($1)/egs;
+
+ if ($single_line) {
+ $value =~ s/(\r?\n)?[ \t]/ /gs;
+ }
+ $value =~ s/^((\r?\n)?[ \t])+//gs;
+ $value =~ s/((\r?\n)?[ \t])+$//gs;
+
+ return $name.': '.$value."\n";
+}
+
+# return full HTTP status line text based on status code
+# fall back to 500
+sub http_status {
+ (my $code) = @_;
+ $code = int($code);
+ if (HTTP_STATUS->{$code} eq '') {
+ $code = 500;
+ }
+ return $code . ' ' . HTTP_STATUS->{$code};
+}
+
+sub http_header_status {
+ (my $code) = @_;
+ return http_header_line(
+ 'status',
+ http_status($code)
+ );
+}
+
+sub http_header_allow {
+ my ($methods) = @_;
+
+ my @list;
+ my $value;
+
+ if (ref($methods)) {
+ @list = @$methods;
+ }
+ else {
+ @list = ($methods,);
+ }
+
+ foreach my $method (@list) {
+ $method = uc($method);
+ if ($method !~ /^(OPTIONS|GET|HEAD|POST|PUT|DELETE|TRACE|CONNECT)$/s) {
+ next;
+ }
+ $value .= (($value ne '') ? ', ' : '').$method;
+ }
+ if ($value eq '') {
+ return '';
+ }
+ return http_header_line('allow', $value);
+}
+
+sub http_header_location {
+ (my $uri) = @_;
+
+ # expect that URL-encoding if needed is already applied
+ if ($uri !~ /^[\x20-\x7f]+$/) {
+ return '';
+ }
+ return http_header_line('location', $uri);
+}
+
+sub http_header_content_length {
+ (my $length) = @_;
+
+ return http_header_line('content-length', int($length));
+}
+
+sub http_header_content_disposition {
+ (my $type, my $filename) = @_;
+
+ if ($type !~ /^[\x21\x23-\x27\x2a\x2b\x2d\x2e\x30-\x39\x3d\x41-\x5a\x5e-\x7a\x7c\x7e]+$/s) {
+ return '';
+ }
+ my $value = lc($type);
+
+ if ($filename ne '') {
+ $value .= '; filename';
+ if ($filename =~ /^[\x21\x23-\x27\x2a\x2b\x2d\x2e\x30-\x39\x3d\x41-\x5a\x5e-\x7a\x7c\x7e]+$/s) {
+ # token
+ $value .= '='.$filename;
+ }
+ elsif ($filename =~ /^[\x20-\x21\x23-\x5b\x5d-\x7e]*$/s) {
+ # quoted-string
+ $value .= '="'.$filename.'"';
+ }
+ elsif ($filename =~ /^[\x00-\xff]*$/) {
+ $value .= "*=ISO-8859-1''".url_encode($filename, 'iso-8859-1');
+ }
+ else {
+ $value .= "*=UTF-8''".url_encode($filename, 'UTF-8');
+ }
+ }
+ return http_header_line('content-disposition', $value);
+}
+
+# sub http_header_content_type {
+ # (my $media_type, my $parameters) = @_;
+ # if ($media_type !~ /^[\x21\x23-\x27\x2a\x2b\x2d\x2e\x30-\x39\x3d\x41-\x5a\x5e-\x7a\x7c\x7e]+\/[\x21\x23-\x27\x2a\x2b\x2d\x2e\x30-\x39\x3d\x41-\x5a\x5e-\x7a\x7c\x7e]+$/s) {
+ # return ''
+ # }
+ # my $value = media_type;
+
+# }
+
# read_header_file() reads a HTTP header file and returns a hash with
# the header values.
# The status line is returned under :http-version, :status-code and
bicyclesonthemoon.info / projects / botm / common-perl / commitdiff