From: Michal Vaner Date: Wed, 8 Oct 2008 19:53:47 +0000 (+0200) Subject: Move UCW perl modules to their directory X-Git-Tag: holmes-import~227^2~5^2~27 X-Git-Url: http://mj.ucw.cz/gitweb/?a=commitdiff_plain;h=89f86d97def2a365b1799f70e3f254264b9c7615;p=libucw.git Move UCW perl modules to their directory This way they can be found from the source directory (needed for configure) --- diff --git a/free/libs/configure b/free/libs/configure index a359da28..6728ce20 100755 --- a/free/libs/configure +++ b/free/libs/configure @@ -17,7 +17,7 @@ BEGIN { die "Don't know how to find myself. Please set SRCDIR manually."; } } - require "$srcdir/ucw/perl/Configure.pm"; + require "$srcdir/ucw/perl/UCW/Configure.pm"; UCW::Configure::import UCW::Configure; } diff --git a/free/libs/examples/internal/configure b/free/libs/examples/internal/configure index 034d43d6..6f4a678d 100755 --- a/free/libs/examples/internal/configure +++ b/free/libs/examples/internal/configure @@ -17,7 +17,7 @@ BEGIN { die "Don't know how to find myself. Please set SRCDIR manually."; } } - require "$srcdir/ucw/perl/Configure.pm"; + require "$srcdir/ucw/perl/UCW/Configure.pm"; UCW::Configure::import UCW::Configure; } diff --git a/ucw/perl/CGI.pm b/ucw/perl/CGI.pm deleted file mode 100644 index 99ab83a9..00000000 --- a/ucw/perl/CGI.pm +++ /dev/null @@ -1,472 +0,0 @@ -# Poor Man's CGI Module for Perl -# -# (c) 2002--2007 Martin Mares -# Slightly modified by Tomas Valla -# -# This software may be freely distributed and used according to the terms -# of the GNU Lesser General Public License. - -# FIXME: -# - respond with proper HTTP error codes -# - if we get invalid parameters, generate HTTP error or redirect - -package UCW::CGI; - -# First of all, set up error handling, so that even errors during parsing -# will be reported properly. - -# Variables to be set by the calling module: -# $UCW::CGI::error_mail mail address of the script admin (optional) -# (this one has to be set in the BEGIN block!) -# $UCW::CGI::error_hook function to be called for reporting errors - -my $error_reported; -my $exit_code; -my $debug = 0; - -sub report_bug($) -{ - if (!defined $error_reported) { - $error_reported = 1; - print STDERR $_[0]; - if (defined($UCW::CGI::error_hook)) { - &$UCW::CGI::error_hook($_[0]); - } else { - print "Content-type: text/plain\n\n"; - print "Internal bug:\n"; - print $_[0], "\n"; - print "Please notify $UCW::CGI::error_mail\n" if defined $UCW::CGI::error_mail; - } - } - die; -} - -BEGIN { - $SIG{__DIE__} = sub { report_bug($_[0]); }; - $SIG{__WARN__} = sub { report_bug("WARNING: " . $_[0]); }; - $exit_code = 0; -} - -END { - $? = $exit_code; -} - -use strict; -use warnings; - -require Exporter; -our $VERSION = 1.0; -our @ISA = qw(Exporter); -our @EXPORT = qw(&html_escape &url_escape &url_deescape &url_param_escape &url_param_deescape &self_ref &self_form &http_get); -our @EXPORT_OK = qw(); - -### Escaping ### - -sub url_escape($) { - my $x = shift @_; - $x =~ s/([^-\$_.!*'(),0-9A-Za-z\x80-\xff])/"%".unpack('H2',$1)/ge; - return $x; -} - -sub url_deescape($) { - my $x = shift @_; - $x =~ s/%(..)/pack("H2",$1)/ge; - return $x; -} - -sub url_param_escape($) { - my $x = shift @_; - $x = url_escape($x); - $x =~ s/%20/+/g; - return $x; -} - -sub url_param_deescape($) { - my $x = shift @_; - $x =~ s/\+/ /g; - return url_deescape($x); -} - -sub html_escape($) { - my $x = shift @_; - $x =~ s/&/&/g; - $x =~ s//>/g; - $x =~ s/"/"/g; - return $x; -} - -### Analysing RFC 822 Style Headers ### - -sub rfc822_prepare($) { - my $x = shift @_; - # Convert all %'s and backslash escapes to %xx escapes - $x =~ s/%/%25/g; - $x =~ s/\\(.)/"%".unpack("H2",$1)/ge; - # Remove all comments, beware, they can be nested (unterminated comments are closed at EOL automatically) - while ($x =~ s/^(("[^"]*"|[^"(])*(\([^)]*)*)(\([^()]*(\)|$))/$1 /) { } - # Remove quotes and escape dangerous characters inside (again closing at the end automatically) - $x =~ s{"([^"]*)("|$)}{my $z=$1; $z =~ s/([^0-9a-zA-Z%_-])/"%".unpack("H2",$1)/ge; $z;}ge; - # All control characters are properly escaped, tokens are clearly visible. - # Finally remove all unnecessary spaces. - $x =~ s/\s+/ /g; - $x =~ s/(^ | $)//g; - $x =~ s{\s*([()<>@,;:\\"/\[\]?=])\s*}{$1}g; - return $x; -} - -sub rfc822_deescape($) { - my $x = shift @_; - return url_deescape($x); -} - -### Reading of HTTP headers ### - -sub http_get($) { - my $h = shift @_; - $h =~ tr/a-z-/A-Z_/; - return $ENV{"HTTP_$h"} || $ENV{"$h"}; -} - -### Parsing of Arguments ### - -my $arg_table; - -sub parse_arg_string($) { - my ($s) = @_; - $s =~ s/\s+//; - foreach $_ (split /[&:]/,$s) { - (/^([^=]+)=(.*)$/) or next; - my $arg = $arg_table->{$1} or next; - $_ = $2; - s/\+/ /g; - s/%(..)/pack("H2",$1)/eg; - s/\r\n/\n/g; - s/\r/\n/g; - $arg->{'multiline'} || s/(\n|\t)/ /g; - s/^\s+//; - s/\s+$//; - if (my $rx = $arg->{'check'}) { - if (!/^$rx$/) { $_ = $arg->{'default'}; } - } - - my $r = ref($arg->{'var'}); - if ($r eq 'SCALAR') { - ${$arg->{'var'}} = $_; - } elsif ($r eq 'ARRAY') { - push @{$arg->{'var'}}, $_; - } - } -} - -sub parse_multipart_form_data(); - -sub parse_args($) { - $arg_table = shift @_; - if (!defined $ENV{"GATEWAY_INTERFACE"}) { - print STDERR "Must be called as a CGI script.\n"; - $exit_code = 1; - exit; - } - foreach my $a (values %$arg_table) { - my $r = ref($a->{'var'}); - defined($a->{'default'}) or $a->{'default'}=""; - if ($r eq 'SCALAR') { - ${$a->{'var'}} = $a->{'default'}; - } elsif ($r eq 'ARRAY') { - @{$a->{'var'}} = (); - } - } - my $method = $ENV{"REQUEST_METHOD"}; - my $qs = $ENV{"QUERY_STRING"}; - parse_arg_string($qs) if defined($qs); - if ($method eq "GET") { - } elsif ($method eq "POST") { - if ($ENV{"CONTENT_TYPE"} =~ /^application\/x-www-form-urlencoded\b/i) { - while () { - chomp; - parse_arg_string($_); - } - } elsif ($ENV{"CONTENT_TYPE"} =~ /^multipart\/form-data\b/i) { - parse_multipart_form_data(); - } else { - die "Unknown content type for POST data"; - } - } else { - die "Unknown request method"; - } -} - -### Parsing Multipart Form Data ### - -my $boundary; -my $boundary_len; -my $mp_buffer; -my $mp_buffer_i; -my $mp_buffer_boundary; -my $mp_eof; - -sub refill_mp_data($) { - my ($more) = @_; - if ($mp_buffer_boundary >= $mp_buffer_i) { - return $mp_buffer_boundary - $mp_buffer_i; - } elsif ($mp_buffer_i + $more <= length($mp_buffer) - $boundary_len) { - return $more; - } else { - if ($mp_buffer_i) { - $mp_buffer = substr($mp_buffer, $mp_buffer_i); - $mp_buffer_i = 0; - } - while ($mp_buffer_i + $more > length($mp_buffer) - $boundary_len) { - last if $mp_eof; - my $data; - my $n = read(STDIN, $data, 2048); - if ($n > 0) { - $mp_buffer .= $data; - } else { - $mp_eof = 1; - } - } - $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i); - if ($mp_buffer_boundary >= 0) { - return $mp_buffer_boundary; - } elsif ($mp_eof) { - return length($mp_buffer); - } else { - return length($mp_buffer) - $boundary_len; - } - } -} - -sub get_mp_line($) { - my ($allow_empty) = @_; - my $n = refill_mp_data(1024); - my $i = index($mp_buffer, "\r\n", $mp_buffer_i); - if ($i >= $mp_buffer_i && $i < $mp_buffer_i + $n - 1) { - my $s = substr($mp_buffer, $mp_buffer_i, $i - $mp_buffer_i); - $mp_buffer_i = $i + 2; - return $s; - } elsif ($allow_empty) { - if ($n) { # An incomplete line - my $s = substr($mp_buffer, $mp_buffer_i, $n); - $mp_buffer_i += $n; - return $s; - } else { # No more lines - return undef; - } - } else { - die "Premature end of multipart POST data"; - } -} - -sub skip_mp_boundary() { - if ($mp_buffer_boundary != $mp_buffer_i) { - die "Premature end of multipart POST data"; - } - $mp_buffer_boundary = -1; - $mp_buffer_i += 2; - my $b = get_mp_line(0); - print STDERR "SEP $b\n" if $debug; - $mp_buffer_boundary = index($mp_buffer, $boundary, $mp_buffer_i); - if ("\r\n$b" =~ /^$boundary--/) { - return 0; - } else { - return 1; - } -} - -sub parse_mp_header() { - my $h = {}; - my $last; - while ((my $l = get_mp_line(0)) ne "") { - print STDERR "HH $l\n" if $debug; - if (my ($name, $value) = ($l =~ /([A-Za-z0-9-]+)\s*:\s*(.*)/)) { - $name =~ tr/A-Z/a-z/; - $h->{$name} = $value; - $last = $name; - } elsif ($l =~ /^\s+/ && $last) { - $h->{$last} .= $l; - } else { - $last = undef; - } - } - foreach my $n (keys %$h) { - $h->{$n} = rfc822_prepare($h->{$n}); - print STDERR "H $n: $h->{$n}\n" if $debug; - } - return (keys %$h) ? $h : undef; -} - -sub parse_multipart_form_data() { - # First of all, find the boundary string - my $ct = rfc822_prepare($ENV{"CONTENT_TYPE"}); - if (!(($boundary) = ($ct =~ /^.*;boundary=([^; ]+)/))) { - die "Multipart content with no boundary string received"; - } - $boundary = rfc822_deescape($boundary); - print STDERR "BOUNDARY IS $boundary\n" if $debug; - - # BUG: IE 3.01 on Macintosh forgets to add the "--" at the start of the boundary string - # as the MIME specs preach. Workaround borrowed from CGI.pm in Perl distribution. - my $agent = http_get("User-agent") || ""; - $boundary = "--$boundary" unless $agent =~ /MSIE\s+3\.0[12];\s*Mac/; - $boundary = "\r\n$boundary"; - $boundary_len = length($boundary) + 2; - - # Check upload size in advance - if (my $size = http_get("Content-Length")) { - my $max_allowed = 0; - foreach my $a (values %$arg_table) { - $max_allowed += $a->{"maxsize"} || 65536; - } - if ($size > $max_allowed) { - die "Maximum form data length exceeded"; - } - } - - # Initialize our buffering mechanism and part splitter - $mp_buffer = "\r\n"; - $mp_buffer_i = 0; - $mp_buffer_boundary = -1; - $mp_eof = 0; - - # Skip garbage before the 1st part - while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; } - skip_mp_boundary() || return; - - # Process individual parts - do { PART: { - print STDERR "NEXT PART\n" if $debug; - my $h = parse_mp_header(); - my ($field, $cdisp, $a); - if ($h && - ($cdisp = $h->{"content-disposition"}) && - $cdisp =~ /^form-data/ && - (($field) = ($cdisp =~ /;name=([^;]+)/)) && - ($a = $arg_table->{"$field"})) { - print STDERR "FIELD $field\n" if $debug; - if (defined $h->{"content-transfer-encoding"}) { die "Unexpected Content-Transfer-Encoding"; } - if (defined $a->{"var"}) { - while (defined (my $l = get_mp_line(1))) { - print STDERR "VALUE $l\n" if $debug; - parse_arg_string("$field=$l"); - } - next PART; - } elsif (defined $a->{"file"}) { - require File::Temp; - require IO::Handle; - my $max_size = $a->{"maxsize"} || 1048576; - my @tmpargs = (undef, UNLINK => 1); - push @tmpargs, DIR => $a->{"tmpdir"} if defined $a->{"tmpdir"}; - my ($fh, $fn) = File::Temp::tempfile(@tmpargs); - print STDERR "FILE UPLOAD to $fn\n" if $debug; - ${$a->{"file"}} = $fn; - ${$a->{"fh"}} = $fh if defined $a->{"fh"}; - my $total_size = 0; - while (my $i = refill_mp_data(4096)) { - print $fh substr($mp_buffer, $mp_buffer_i, $i); - $mp_buffer_i += $i; - $total_size += $i; - if ($total_size > $max_size) { die "Uploaded file too long"; } - } - $fh->flush(); # Don't close the handle, the file would disappear otherwise - next PART; - } - } - print STDERR "SKIPPING\n" if $debug; - while (my $i = refill_mp_data(256)) { $mp_buffer_i += $i; } - } } while (skip_mp_boundary()); -} - -### Generating Self-ref URL's ### - -sub make_out_args($) { - my ($overrides) = @_; - my $out = {}; - foreach my $name (keys %$arg_table) { - my $arg = $arg_table->{$name}; - defined($arg->{'var'}) || next; - defined($arg->{'pass'}) && !$arg->{'pass'} && !exists $overrides->{$name} && next; - my $value; - if (!defined($value = $overrides->{$name})) { - if (exists $overrides->{$name}) { - $value = $arg->{'default'}; - } else { - $value = ${$arg->{'var'}}; - } - } - if ($value ne $arg->{'default'}) { - $out->{$name} = $value; - } - } - return $out; -} - -sub self_ref(@) { - my %h = @_; - my $out = make_out_args(\%h); - return "?" . join(':', map { "$_=" . url_param_escape($out->{$_}) } sort keys %$out); -} - -sub self_form(@) { - my %h = @_; - my $out = make_out_args(\%h); - return join('', map { "\n" } sort keys %$out); -} - -### Cookies - -sub set_cookie($$@) { - # - # Unfortunately, the support for the new cookie standard (RFC 2965) among - # web browsers is still very scarce, so we are still using the old Netscape - # specification. - # - # Usage: set_cookie(name, value, option => value...), where options are: - # - # max-age maximal age in seconds - # domain domain name scope - # path path name scope - # secure if present, cookie applies only to SSL connections - # (in this case, the value should be undefined) - # discard if present with any value, the cookie is discarded - # - - my $key = shift @_; - my $value = shift @_; - my %other = @_; - if (exists $other{'discard'}) { - delete $other{'discard'}; - $other{'max-age'} = 0; - } - if (defined(my $age = $other{'max-age'})) { - delete $other{'max-age'}; - my $exp = ($age ? (time + $age) : 0); - # Avoid problems with locales - my ($S,$M,$H,$d,$m,$y,$wd) = gmtime $exp; - my @wdays = ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' ); - my @mons = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' ); - $other{'expires'} = sprintf("%s, %02d-%s-%d %02d:%02d:%02d GMT", - $wdays[$wd], $d, $mons[$m], $y+1900, $H, $M, $S); - } - - print "Set-Cookie: $key=", url_escape($value); - foreach my $k (keys %other) { - print "; $k"; - print "=", $other{$k} if defined $other{$k}; - } - print "\n"; -} - -sub parse_cookies() { - my $h = http_get("Cookie") or return (); - my @cook = (); - foreach my $x (split /;\s*/, $h) { - my ($k,$v) = split /=/, $x; - $v = url_deescape($v) if defined $v; - push @cook, $k => $v; - } - return @cook; -} - -1; # OK diff --git a/ucw/perl/Config.pm b/ucw/perl/Config.pm deleted file mode 100644 index 552690ca..00000000 --- a/ucw/perl/Config.pm +++ /dev/null @@ -1,54 +0,0 @@ -# Perl module for parsing Sherlock configuration files (using the config utility) -# -# (c) 2002--2005 Martin Mares -# -# This software may be freely distributed and used according to the terms -# of the GNU Lesser General Public License. - -package UCW::Config; - -use strict; -use warnings; -use Getopt::Long; - -our %Sections = (); - -our $DefaultConfigFile = ""; -our $Usage = "-C, --config filename Override the default configuration file --S, --set sec.item=val Manual setting of a configuration item"; - - -sub Parse(@) { - my @options = @_; - my $defargs = ""; - my $override_config = 0; - push @options, "config|C=s" => sub { my ($o,$a)=@_; $defargs .= " -C'$a'"; $override_config=1; }; - push @options, "set|S=s" => sub { my ($o,$a)=@_; $defargs .= " -S'$a'"; }; - Getopt::Long::Configure("bundling"); - Getopt::Long::GetOptions(@options) or return 0; - if (!$override_config && $DefaultConfigFile) { - $defargs = "-C'$DefaultConfigFile' $defargs"; - } - foreach my $section (keys %Sections) { - my $opts = $Sections{$section}; - my $optlist = join(";", keys %$opts); - my %filtered_opts = map { my $t=$_; $t=~s/[#\$]+$//; $t => $$opts{$_} } keys %$opts; - my @l = `bin/config $defargs "$section\{$optlist\}"`; - $? && exit 1; - foreach my $o (@l) { - $o =~ /^CF_.*_([^=]+)='(.*)'\n$/ or die "Cannot parse bin/config output: $_"; - my $var = $filtered_opts{$1}; - my $val = $2; - if (ref $var eq "SCALAR") { - $$var = $val; - } elsif (ref $var eq "ARRAY") { - push @$var, $val; - } elsif (ref $var) { - die ("UCW::Config::Parse: don't know how to set $o"); - } - } - } - 1; -} - -1; # OK diff --git a/ucw/perl/Configure.pm b/ucw/perl/Configure.pm deleted file mode 100644 index e0f501d7..00000000 --- a/ucw/perl/Configure.pm +++ /dev/null @@ -1,287 +0,0 @@ -# Perl module for UCW Configure Scripts -# -# (c) 2005 Martin Mares -# -# This software may be freely distributed and used according to the terms -# of the GNU Lesser General Public License. - -package UCW::Configure; - -use strict; -use warnings; - -BEGIN { - # The somewhat hairy Perl export mechanism - use Exporter(); - our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS); - $VERSION = 1.0; - @ISA = qw(Exporter); - @EXPORT = qw(&Init &Log &Notice &Warn &Fail &IsSet &IsGiven &Set &UnSet &Append &Override &Get &Test &Include &Finish &FindFile &TryFindFile &TryCmd &PkgConfig &TrivConfig); - @EXPORT_OK = qw(); - %EXPORT_TAGS = (); -} - -our %vars = (); -our %overriden = (); - -sub Log($) { - print @_; -} - -sub Notice($) { - print @_ if $vars{"VERBOSE"}; -} - -sub Warn($) { - print "WARNING: ", @_; -} - -sub Fail($) { - Log("ERROR: " . (shift @_) . "\n"); - exit 1; -} - -sub IsSet($) { - my ($x) = @_; - return exists $vars{$x}; -} - -sub IsGiven($) { - my ($x) = @_; - return exists $overriden{$x}; -} - -sub Get($) { - my ($x) = @_; - return $vars{$x}; -} - -sub Set($;$) { - my ($x,$y) = @_; - $y=1 unless defined $y; - $vars{$x}=$y unless $overriden{$x}; -} - -sub UnSet($) { - my ($x) = @_; - delete $vars{$x} unless $overriden{$x}; -} - -sub Append($$) { - my ($x,$y) = @_; - Set($x, (IsSet($x) ? (Get($x) . " $y") : $y)); -} - -sub Override($;$) { - my ($x,$y) = @_; - $y=1 unless defined $y; - $vars{$x}=$y; - $overriden{$x} = 1; -} - -sub Test($$$) { - my ($var,$msg,$sub) = @_; - Log "$msg ... "; - if (!IsSet($var)) { - Set $var, &$sub(); - } - Log Get($var) . "\n"; -} - -sub TryFindFile($) { - my ($f) = @_; - if (-f $f) { - return $f; - } elsif ($f !~ /^\// && -f (Get("SRCDIR")."/$f")) { - return Get("SRCDIR")."/$f"; - } else { - return undef; - } -} - -sub FindFile($) { - my ($f) = @_; - my $F; - defined ($F = TryFindFile($f)) or Fail "Cannot find file $f"; - return $F; -} - -sub Init($$) { - my ($srcdir,$defconfig) = @_; - sub usage($) { - my ($dc) = @_; - print STDERR "Usage: [/]configure " . (defined $dc ? "[" : "") . "" . (defined $dc ? "]" : "") . - " [