Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Move shared module CGI::Deurl::XS from spam repo to modules repo

  • Loading branch information...
commit f1ac7f81fb227582bd0f439f46e81746b27468ba 0 parents
@athomason authored
127 CGI-Deurl-XS.spec
@@ -0,0 +1,127 @@
+#
+# - CGI::Deurl::XS -
+# This spec file was automatically generated by cpan2rpm [ver: 2.028]
+# The following arguments were used:
+# CGI-Deurl-XS-0.05.tar.gz
+# For more information on cpan2rpm please visit: http://perl.arix.com/
+#
+
+%define pkgname CGI-Deurl-XS
+%define filelist %{pkgname}-%{version}-filelist
+%define NVR %{pkgname}-%{version}-%{release}
+%define maketest 1
+
+name: perl-CGI-Deurl-XS
+summary: CGI-Deurl-XS - Fast decoder for URL parameter strings
+version: 0.05
+release: 1
+vendor: Adam Thomason <athomason@sixapart.com>
+packager: Arix International <cpan2rpm@arix.com>
+license: Artistic
+group: Applications/CPAN
+url: http://www.cpan.org
+buildroot: %{_tmppath}/%{name}-%{version}-%(id -u -n)
+buildarch: x86_64
+prefix: %(echo %{_prefix})
+source: CGI-Deurl-XS-0.05.tar.gz
+
+%description
+This module decodes a URL-encoded parameter string in the manner of CGI.pm.
+However, as it uses C code from libapreq to perform the task, it's somewhere
+from slightly to much faster (depending on your strings) than using CGI or a
+functionally similar module like CGI::Deurl.
+
+#
+# This package was generated automatically with the cpan2rpm
+# utility. To get this software or for more information
+# please visit: http://perl.arix.com/
+#
+
+%prep
+%setup -q -n %{pkgname}-%{version}
+chmod -R u+w %{_builddir}/%{pkgname}-%{version}
+
+%build
+grep -rsl '^#!.*perl' . |
+grep -v '.bak$' |xargs --no-run-if-empty \
+%__perl -MExtUtils::MakeMaker -e 'MY->fixin(@ARGV)'
+CFLAGS="$RPM_OPT_FLAGS"
+%{__perl} Makefile.PL `%{__perl} -MExtUtils::MakeMaker -e ' print qq|PREFIX=%{buildroot}%{_prefix}| if \$ExtUtils::MakeMaker::VERSION =~ /5\.9[1-6]|6\.0[0-5]/ '`
+%{__make}
+%if %maketest
+%{__make} test
+%endif
+
+%install
+[ "%{buildroot}" != "/" ] && rm -rf %{buildroot}
+
+%{makeinstall} `%{__perl} -MExtUtils::MakeMaker -e ' print \$ExtUtils::MakeMaker::VERSION <= 6.05 ? qq|PREFIX=%{buildroot}%{_prefix}| : qq|DESTDIR=%{buildroot}| '`
+
+cmd=/usr/share/spec-helper/compress_files
+[ -x $cmd ] || cmd=/usr/lib/rpm/brp-compress
+[ -x $cmd ] && $cmd
+
+# SuSE Linux
+if [ -e /etc/SuSE-release -o -e /etc/UnitedLinux-release ]
+then
+ %{__mkdir_p} %{buildroot}/var/adm/perl-modules
+ %{__cat} `find %{buildroot} -name "perllocal.pod"` \
+ | %{__sed} -e s+%{buildroot}++g \
+ > %{buildroot}/var/adm/perl-modules/%{name}
+fi
+
+# remove special files
+find %{buildroot} -name "perllocal.pod" \
+ -o -name ".packlist" \
+ -o -name "*.bs" \
+ |xargs -i rm -f {}
+
+# no empty directories
+find %{buildroot}%{_prefix} \
+ -type d -depth \
+ -exec rmdir {} \; 2>/dev/null
+
+%{__perl} -MFile::Find -le '
+ find({ wanted => \&wanted, no_chdir => 1}, "%{buildroot}");
+ print "%doc parser Changes fallback README";
+ for my $x (sort @dirs, @files) {
+ push @ret, $x unless indirs($x);
+ }
+ print join "\n", sort @ret;
+
+ sub wanted {
+ return if /auto$/;
+
+ local $_ = $File::Find::name;
+ my $f = $_; s|^\Q%{buildroot}\E||;
+ return unless length;
+ return $files[@files] = $_ if -f $f;
+
+ $d = $_;
+ /\Q$d\E/ && return for reverse sort @INC;
+ $d =~ /\Q$_\E/ && return
+ for qw|/etc %_prefix/man %_prefix/bin %_prefix/share|;
+
+ $dirs[@dirs] = $_;
+ }
+
+ sub indirs {
+ my $x = shift;
+ $x =~ /^\Q$_\E\// && $x ne $_ && return 1 for @dirs;
+ }
+ ' > %filelist
+
+[ -z %filelist ] && {
+ echo "ERROR: empty %files listing"
+ exit -1
+ }
+
+%clean
+[ "%{buildroot}" != "/" ] && rm -rf %{buildroot}
+
+%files -f %filelist
+%defattr(-,root,root)
+
+%changelog
+* Wed May 2 2007 athomason@athomason
+- Initial build.
14 Changes
@@ -0,0 +1,14 @@
+Revision history for Perl extension CGI::Deurl::XS.
+
+0.07 Wed Jun 18 22:43:01 2008
+ - provide strndup since not all libc's have it
+0.06 Wed Jun 18 12:02:03 2008
+ - initial CPAN release
+0.03 Thu Apr 19 16:11:47 2007
+ - kick out the SV leaks, add tests and docs.
+0.02 Thu Apr 19 03:50:08 2007
+ - initial semi-working version which passes some tests. leaks like a sieve.
+0.01 Wed Apr 18 19:45:24 2007
+ - original version; created by h2xs 1.23 with options
+ -O -n CGI::Deurl::XS -b 5.8.0 ./CGI-Deurl-XS/parser/parser.h
+
14 MANIFEST
@@ -0,0 +1,14 @@
+Changes
+Makefile.PL
+MANIFEST
+ppport.h
+README
+XS.xs
+t/CGI-Deurl-XS.t
+fallback/const-c.inc
+fallback/const-xs.inc
+XS.pm
+parser/Makefile.PL
+parser/parser.c
+parser/parser.h
+META.yml Module meta-data (added by MakeMaker)
13 META.yml
@@ -0,0 +1,13 @@
+--- #YAML:1.0
+name: CGI-Deurl-XS
+version: 0.07
+abstract: Fast decoder for URL parameter strings
+license: ~
+generated_by: ExtUtils::MakeMaker version 6.36
+distribution_type: module
+requires:
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.2.html
+ version: 1.2
+author:
+ - Adam Thomason <athomason@sixapart.com>
48 Makefile.PL
@@ -0,0 +1,48 @@
+use 5.008;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => 'CGI::Deurl::XS',
+ VERSION_FROM => 'XS.pm', # finds $VERSION
+ PREREQ_PM => {}, # e.g., Module::Name => 1.1
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => 'XS.pm', # retrieve abstract from module
+ AUTHOR => 'Adam Thomason <athomason@sixapart.com>') : ()),
+ LIBS => [''], # e.g., '-lm'
+ DEFINE => '', # e.g., '-DHAVE_SOMETHING'
+ INC => '-I.', # e.g., '-I. -I/usr/include/other'
+ # Un-comment this if you add C files to link with later:
+ # OBJECT => '$(O_FILES)', # link all the C files too
+ MYEXTLIB => 'parser/libparser$(LIB_EXT)',
+);
+if (eval {require ExtUtils::Constant; 1}) {
+ # If you edit these definitions to change the constants used by this module,
+ # you will need to use the generated const-c.inc and const-xs.inc
+ # files to replace their "fallback" counterparts before distributing your
+ # changes.
+ my @names = (qw());
+ ExtUtils::Constant::WriteConstants(
+ NAME => 'CGI::Deurl::XS',
+ NAMES => \@names,
+ DEFAULT_TYPE => 'IV',
+ C_FILE => 'const-c.inc',
+ XS_FILE => 'const-xs.inc',
+ );
+
+}
+else {
+ use File::Copy;
+ use File::Spec;
+ foreach my $file ('const-c.inc', 'const-xs.inc') {
+ my $fallback = File::Spec->catfile('fallback', $file);
+ copy ($fallback, $file) or die "Can't copy $fallback to $file: $!";
+ }
+}
+
+sub MY::postamble {
+'
+$(MYEXTLIB): parser/Makefile
+ cd parser && $(MAKE) $(PASSTHRU)
+';
+}
27 README
@@ -0,0 +1,27 @@
+CGI-Deurl-XS version 0.01
+=========================
+
+This module decodes URL-encoded parameter strings in the manner of CGI.pm,
+but faster.
+
+INSTALLATION
+
+To install this module type the following:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+COPYRIGHT AND LICENCE
+
+Written by Adam Thomason, <athomason@sixapart.com>
+
+Copyright (C) 2007 by Six Apart Ltd <cpan@sixapart.com>
+
+Portions copyright The Apache Software Foundation.
+Used under the Apache License v2.0.
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.6 or,
+at your option, any later version of Perl 5 you may have available.
112 XS.pm
@@ -0,0 +1,112 @@
+package CGI::Deurl::XS;
+
+use 5.008;
+use strict;
+use warnings;
+use Carp;
+
+require Exporter;
+use AutoLoader;
+
+our @ISA = qw(Exporter);
+
+our @EXPORT_OK = qw/parse_query_string/;
+our @EXPORT = qw();
+
+our $VERSION = '0.07';
+
+sub AUTOLOAD {
+ # This AUTOLOAD is used to 'autoload' constants from the constant()
+ # XS function.
+
+ my $constname;
+ our $AUTOLOAD;
+ ($constname = $AUTOLOAD) =~ s/.*:://;
+ croak "&CGI::Deurl::XS::constant not defined" if $constname eq 'constant';
+ my ($error, $val) = constant($constname);
+ if ($error) { croak $error; }
+ {
+ no strict 'refs';
+ # Fixed between 5.005_53 and 5.005_61
+#XXX if ($] >= 5.00561) {
+#XXX *$AUTOLOAD = sub () { $val };
+#XXX }
+#XXX else {
+ *$AUTOLOAD = sub { $val };
+#XXX }
+ }
+ goto &$AUTOLOAD;
+}
+
+require XSLoader;
+XSLoader::load('CGI::Deurl::XS', $VERSION);
+
+# Preloaded methods go here.
+
+# Autoload methods go after =cut, and are processed by the autosplit program.
+
+1;
+__END__
+
+=head1 NAME
+
+CGI::Deurl::XS - Fast decoder for URL parameter strings
+
+=head1 SYNOPSIS
+
+ use CGI::Deurl::XS 'parse_query_string';
+
+ my $hash = parse_query_string('foo=bar&baz=quux&baz=qiix');
+ # $hash = { 'foo' => 'bar', 'baz' => ['quux', 'qiix'] };
+
+=head1 DESCRIPTION
+
+This module decodes a URL-encoded parameter string in the manner of CGI.pm.
+However, as it uses C code from libapreq to perform the task, it's somewhere
+from slightly to much faster (depending on your strings) than using L<CGI> or a
+functionally similar module like L<CGI::Deurl>.
+
+=head1 FUNCTIONS
+
+=over 4
+
+=item parse_query_string()
+
+ $hash_ref = CGI::Deurl::XS::parse_query_string($query_string)
+
+Parses the given query string. If the string is empty, returns undef. Otherwise
+returns a hash reference containing the key/value pairs encoded by the string.
+Empty values are returned as undef. If a parameter appears only once, it's
+value in the hash is the scalar value of the encoded parameter value. If a
+parameter appears more than once, the hash value is an array reference
+containing each value given (with value order preserved). Obviously, parameter
+order is not preserved in the hash.
+
+HTTP escapes (ASCII and Unicode) are decoded in both keys and values. The utf8
+flag is not set on returned strings, nor are non-utf8 encodings decoded.
+
+=back
+
+=head1 EXPORT
+
+None by default, parse_query_string at request.
+
+=head1 SEE ALSO
+
+L<CGI>
+
+L<libapreq>
+
+=head1 AUTHOR
+
+Adam Thomason, E<lt>athomason@sixapart.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2008 by Six Apart Ltd <cpan@sixapart.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.6 or,
+at your option, any later version of Perl 5 you may have available.
+
+=cut
30 XS.xs
@@ -0,0 +1,30 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "ppport.h"
+
+#include <parser/parser.h>
+
+#include "const-c.inc"
+
+MODULE = CGI::Deurl::XS PACKAGE = CGI::Deurl::XS
+
+INCLUDE: const-xs.inc
+
+SV*
+parse_query_string(query)
+ char* query
+CODE:
+ if (!query) {
+ XSRETURN_UNDEF;
+ }
+ SV* sv = _split_to_parms(query);
+ if (sv) {
+ RETVAL = sv;
+ }
+ else {
+ XSRETURN_UNDEF;
+ }
+OUTPUT:
+ RETVAL
63 bench.pl
@@ -0,0 +1,63 @@
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+use Benchmark ':hireswallclock';
+use CGI::Deurl 'NOTCGI';
+use CGI::Deurl::XS qw/parse_query_string parse_decode_query_string/;
+
+use open qw/ :std :utf8 /;
+
+use Data::Dumper;
+use YAML::Syck;
+
+#use encoding 'utf8';
+
+my @chars = ('A'..'Z', 'a'..'z', '+');
+sub spew { return join '', map { $chars[rand @chars] } 1..shift }
+
+#my $string = shift || 'foo=bar';
+my %stuff = (
+ 'foo' => 'bar',
+ 'blah' => 'baz',
+ 'eep' => 'anima',
+ spew(5) => spew(10000),
+);
+my $simple = 'f=1';
+my $random = join '&', map { "$_=$stuff{$_}" } keys %stuff;
+my $russian = 'http://ads1.dev.sixapart.com/js/?p=lj&id=id&f=insertAd&country=&width=160&language=en&interests=%D0%BC%D1%83%D0%B7%D1%8B%D0%BA%D0%B0,madonna,%D0%BD%D0%BE%D1%87%D1%8C,80%27s,%D1%81%D0%BD%D1%8B,%D0%B4%D0%B8%D0%B7%D0%B0%D0%B9%D0%BD,%D0%BB%D1%8E%D0%B4%D0%B8,%D1%8E%D0%BC%D0%BE%D1%80,%D0%B4%D0%B5%D0%BD%D1%8C%D0%B3%D0%B8,%D1%80%D0%B5%D0%BA%D0%BB%D0%B0%D0%BC%D0%B0,%D0%BB%D1%83%D0%BD%D0%B0,skin,%D1%81%D0%B2%D0%B5%D1%87%D0%B8,abba,%D0%B3%D0%BB%D0%B8%D0%BD%D1%82%D0%B2%D0%B5%D0%B9%D0%BD,%D0%B9%D0%BE%D0%B3%D0%B0,%D0%BC%D0%B5%D1%87%D1%82%D1%8B,%D0%BF%D0%BE%D0%B7%D0%B8%D1%82%D0%B8%D0%B2,%D0%B4%D0%B6%D0%B8%D0%BD%D1%81%D1%8B,%D0%B7%D0%B0%D0%BF%D0%B0%D1%85%D0%B8,%D0%9A%D0%92%D0%9D,%D0%BB%D0%B5%D0%BD%D1%8C,%D0%BA%D0%BE%D1%82%D1%8B,%D0%B3%D0%B0%D1%80%D0%BC%D0%BE%D0%BD%D0%B8%D1%8F,%D1%8F%D0%B7%D1%8B%D0%BA%D0%B8,%D0%B3%D0%BE%D1%80%D0%BE%D0%B4%D0%B0,%D0%BA%D1%80%D0%B0%D1%81%D0%BD%D0%BE%D0%B5+%D0%B2%D0%B8%D0%BD%D0%BE,%D0%BC%D1%8F%D1%81%D0%BE,%D0%BF%D0%B0%D1%80%D0%BD%D0%B8,%D1%87%D1%83%D0%B4%D0%B5%D1%81%D0%B0,%D1%80%D1%83%D1%81%D1%81%D0%BA%D0%B8%D0%B9+%D1%8F%D0%B7%D1%8B%D0%BA,%D0%B3%D1%80%D0%B8%D0%B1%D1%8B,%D1%88%D0%BE%D0%BF%D0%BF%D0%B8%D0%BD%D0%B3,%D0%94%D0%B0%D0%BB%D0%B8,%D0%BD%D0%B5+%D1%81%D0%BF%D0%B0%D1%82%D1%8C,%D0%BA%D0%B0%D0%BC%D0%BD%D0%B8,%D0%B3%D0%B5%D0%B8,%D0%B4%D0%B0%D1%80%D0%B8%D1%82%D1%8C,%D0%B2%D0%BE%D0%BB%D0%BE%D1%81%D1%8B,tina+turner,%D0%BB%D0%B5%D0%B4,sea+food,%D0%B3%D0%B0%D0%B4%D0%B0%D0%BD%D0%B8%D1%8F,%D1%81%D0%BB%D0%BE%D0%BD%D1%8B,%D0%A8%D0%B2%D0%B5%D1%86%D0%B8%D1%8F,%D1%84%D1%8D%D0%BD-%D1%88%D1%83%D0%B9,%D0%90%D0%BB%D0%B8%D1%81%D0%B0+%D0%B2+%D1%81%D1%82%D1%80%D0%B0%D0%BD%D0%B5+%D1%87%D1%83%D0%B4%D0%B5%D1%81,%D0%A2%D0%92,%D1%81%D0%BB%D0%BE%D0%B2%D0%B0%D1%80%D0%B8,%D1%82%D0%B5%D0%BC%D0%BD%D0%BE%D0%B5+%D0%BF%D0%B8%D0%B2%D0%BE,%D0%91%D0%B5%D1%80%D0%BB%D0%B8%D0%BD,%D0%B3%D0%B0%D1%88%D0%B8%D1%88,%D0%BA%D0%BB%D0%B8%D0%BF%D1%8B,%D0%BA%D1%80%D0%B0%D1%81%D0%B8%D0%B2%D1%8B%D0%B5+%D0%BC%D0%B0%D1%88%D0%B8%D0%BD%D1%8B,%D0%91%D0%B5%D1%80%D1%80%D0%BE%D1%83%D0%B7,%D0%96%D0%B0%D0%BD%D0%BD%D0%B0+%D0%90%D0%B3%D1%83%D0%B7%D0%B0%D1%80%D0%BE%D0%B2%D0%B0,%D0%91%D0%BE%D1%80%D0%B8%D1%81+%D0%92%D0%B8%D0%B0%D0%BD,%D0%B1%D0%B8%D1%80%D0%B6%D0%B0,%D0%BC%D0%BE%D0%BB%D0%BE%D1%87%D0%BD%D1%8B%D0%B5+%D0%BA%D0%BE%D0%BA%D1%82%D0%B5%D0%B9%D0%BB%D0%B8,%D0%BF%D0%B0%D1%81%D1%82%D0%B0,%D1%88%D1%82%D1%83%D1%87%D0%BA%D0%B8,%D0%B0%D0%BD%D0%B4%D0%B5%D1%80%D0%B3%D1%80%D0%B0%D1%83%D0%BD%D0%B4,%D1%81%D0%B8%D0%B4%D0%B5%D1%82%D1%8C+%D0%BD%D0%B0+%D0%BE%D0%BA%D0%BD%D0%B5,%D1%81%D1%8B%D1%80%D1%8B,%D0%98%D0%BB%D1%8C%D1%8F+%D0%9B%D0%B0%D0%B3%D1%83%D1%82%D0%B5%D0%BD%D0%BA%D0%BE,%D0%A1%D0%B8%D0%BD%D0%B0%D0%B9,%D0%9D%D0%B0%D1%82%D0%B0%D0%BB%D0%B8%D1%8F+%D0%9C%D0%B5%D0%B4%D0%B2%D0%B5%D0%B4%D0%B5%D0%B2%D0%B0,%D0%BC%D0%BD%D0%BE%D0%B3%D0%BE%D0%BE%D0%B1%D1%80%D0%B0%D0%B7%D0%B8%D0%B5,%D0%B8%D0%B3%D1%80%D0%B0%D1%82%D1%8C+%D0%B2+%D0%BC%D0%B0%D1%84%D0%B8%D1%8E,%D0%91%D0%B0%D1%80%D0%B1%D0%B0%D1%80%D0%B0+%D0%A1%D1%82%D1%80%D0%B5%D0%B9%D0%B7%D0%B0%D0%BD%D0%B4,%D0%BF%D0%BE%D0%BE%D1%80%D0%B0%D1%82%D1%8C,%D0%B4%D1%80%D0%B5%D0%B2%D0%BD%D0%B8%D0%B5+%D0%B3%D1%80%D0%B5%D0%BA%D0%B8,%D0%9C%D0%B0%D1%80%D0%B8%D0%B0%D0%BD%D0%BD%D0%B0,%D1%85%D0%B8%D1%82%D1%8B,%D0%BC%D0%B0%D1%82%D0%B5%D1%80%D0%BD%D1%8B%D0%B5+%D1%81%D0%BB%D0%BE%D0%B2%D0%B0,%D0%BF%D1%81%D0%B5%D0%B2%D0%B4%D0%BE%D0%BD%D0%B8%D0%BC%D1%8B,%D7%90%D7%A8%D7%A5+%D7%A0%D7%94%D7%93%D7%A8%D7%AA,%D0%94%D0%B6%D0%B5%D0%B9%D0%BC%D1%81,%D0%B7%D0%B0%D0%BF%D0%B8%D1%81%D0%BA%D0%B8+%D0%BD%D0%B0+%D1%85%D0%BE%D0%BB%D0%BE%D0%B4%D0%B8%D0%BB%D1%8C%D0%BD%D0%B8%D0%BA%D0%B5,%D0%BF%D1%80%D0%B8%D0%BA%D0%BE%D0%BB%D1%8C%D0%BD%D0%B0%D1%8F+%D0%BE%D0%B1%D1%83%D0%B2%D1%8C,%D0%B2%D0%BE%D0%B7%D0%B2%D1%80%D0%B0%D1%89%D0%B0%D1%82%D1%8C%D1%81%D1%8F+%D0%BF%D0%BE%D0%B4+%D1%83%D1%82%D1%80%D0%BE,%D0%96%D0%B0%D0%BD,%D1%87%D1%83%D0%B6%D0%B8%D0%B5+%D0%B2%D0%BE%D1%81%D0%BF%D0%BE%D0%BC%D0%B8%D0%BD%D0%B0%D0%BD%D0%B8%D1%8F,%D0%A0%D0%B0%D0%BC%D0%B0%D1%82-%D0%93%D0%B0%D0%BD,%D0%B4%D1%80%D1%83%D0%B6%D0%B5%D1%81%D0%BA%D0%B8%D0%B5+%D0%BF%D1%8C%D1%8F%D0%BD%D0%BA%D0%B8,%D0%BA%D1%80%D0%B0%D1%81%D0%B8%D0%B2%D1%8B%D0%B5+%D0%B4%D0%B5%D1%80%D0%B5%D0%B2%D1%8C%D1%8F,%22%D0%BD%D0%B5%D1%80%D0%B5%D1%81%D1%82%22,dolce+pontes,%D0%B3%D0%BB%D1%8F%D0%BD%D1%86%D0%B5%D0%B2%D1%8B%D0%B5+%D0%B0%D0%BB%D1%8C%D0%B1%D0%BE%D0%BC%D1%8B,%D0%B8%D1%86%D0%B7%D1%8B%D0%BD,%D1%80%D0%B0%D0%B7%D0%BD%D0%B0%D1%8F+%D1%87%D1%83%D1%88%D1%8C,%D1%80%D0%BE%D1%8F%D0%BB%D0%B8+%D0%B8+%D0%BF%D0%B8%D0%B0%D0%BD%D0%B8%D0%BD%D0%BE,%D7%A1%D7%95%D7%A4%D7%A8%D7%A4%D7%90%D7%A8%D7%9D,%D7%A2%D7%95%D7%A4%D7%A8+%D7%A0%D7%99%D7%A1%D7%99%D7%9D&contents=&categories=TRAV,DATE,SHOP,ARTS,MUSIC,FUN&channel=Journal-Skyscraper&adunit=skyscraper&accttype=ADS&age=36&height=600&url=http://ilyush.livejournal.com/&type=content&gender=';
+my $english = 'http://ads1.dev.sixapart.com/js/?p=lj&id=id&f=insertAd&country=&width=728&language=en&interests=&contents=I+don%27t+love+you+as+if+you+were+the+salt-rose,+topazor+arrow+of+carnations+that+propagate+fire:I+love+you+as+certain+dark+things+are+loved,secretly,+between+the+shadow+and+the+soul.I+love+you+as+the+plant+that+doesn%27t+bloom+and+carrieshidden+within+itself+the+light+of+those+flowers,and+thanks+to+your+love,+darkly+in+my+bodylives+the+dense+fragrance+that+rises+from+the+earth.I+love+you+without+knowing+how,+or+when,+or+from+where,I+love+you+simply,+without+problems+or+pride:I+love+you+in+this+way+because+I+don%27t+know+any+other+way+of+lovingbut+this,+in+which+there+is+no+I+or+you,so+intimate+that+your+hand+upon+my+chest+is+my+hand,so+intimate+that+when+I+fall+asleep+it+is+your+eyes+that+close.Sonnet+XVII:+Love+pablo+nerudaI+would+really+love+to+stop+feeling+this+jaded,+I+wander+how+much+more+I+could+take.+Migraine+seems+to+be+a+package+with+jaded-ness%3FOn+a+really+happier+note,+thank+goodness+nothing+happened+to+Wanni%27s+Grandpa.+And+I+am+really+glad+for+Ame%27s+existence.+:%29Yesterday+was+the&categories=&channel=Journal-Leaderboard-Bottom&adunit=leaderboard-bottom&accttype=ADS&age=36&height=90&url=http://of_unspoken.livejournal.com/&type=content&gender=';
+
+for my $string ($simple, $random, $english, $russian) {
+ printf "String length: %d\n", length $string;
+ {
+ my $nonxs = {};
+ CGI::Deurl::deurl($string, $nonxs);
+ my $xs = parse_query_string($string);
+ my $xsdec = parse_decode_query_string($string);
+ my %parsed = (nonxs => $nonxs, xs => $xs, xsdec => $xsdec);
+ print Data::Dumper->Dump([$nonxs, $xs, $xsdec], [qw/ nonxs xs xsdec /]), "\n";
+ print YAML::Syck::Dump(\%parsed), "\n";
+ for my $thing (sort keys %parsed) {
+ my $d = $parsed{$thing};
+ print "$thing\n";
+ for my $key (sort keys %$d) {
+ print " $key=$d->{$key}\n";
+ }
+ }
+ print "\n";
+ }
+ my $params = {};
+ timethese(-5, {
+ 'CGI::Deurl::deurl' => sub {
+ $params = {};
+ CGI::Deurl::deurl($string, $params);
+ },
+ 'CGI::Deurl::XS::parse_query_string' => sub {
+ parse_query_string($string)
+ },
+ 'CGI::Deurl::XS::parse_decode_query_string' => sub {
+ parse_decode_query_string($string)
+ },
+ });
+}
55 const-c.inc
@@ -0,0 +1,55 @@
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF 2
+#define PERL_constant_ISIV 3
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISSV 8
+#define PERL_constant_ISUNDEF 9
+#define PERL_constant_ISUV 10
+#define PERL_constant_ISYES 11
+
+#ifndef NVTYPE
+typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+#endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support. */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support. */
+#endif
+
+static int
+constant (pTHX_ const char *name, STRLEN len) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+#!/usr/bin/perl -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw()};
+my @names = (qw());
+
+print constant_types(); # macro defs
+foreach (C_constant ("CGI::Deurl::XS", 'constant', 'IV', $types, undef, 3, @names) ) {
+ print $_, "\n"; # C constant subs
+}
+print "#### XS Section:\n";
+print XS_constant ("CGI::Deurl::XS", $types);
+__END__
+ */
+
+ switch (len) {
+ }
+ return PERL_constant_NOTFOUND;
+}
+
87 const-xs.inc
@@ -0,0 +1,87 @@
+void
+constant(sv)
+ PREINIT:
+#ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+#else
+ dTARGET;
+#endif
+ STRLEN len;
+ int type;
+ /* IV iv; Uncomment this if you need to return IVs */
+ /* NV nv; Uncomment this if you need to return NVs */
+ /* const char *pv; Uncomment this if you need to return PVs */
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ type = constant(aTHX_ s, len);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid CGI::Deurl::XS macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined CGI::Deurl::XS macro %s, used", s));
+ PUSHs(sv);
+ break;
+ /* Uncomment this if you need to return IVs
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break; */
+ /* Uncomment this if you need to return NOs
+ case PERL_constant_ISNO:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_no);
+ break; */
+ /* Uncomment this if you need to return NVs
+ case PERL_constant_ISNV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHn(nv);
+ break; */
+ /* Uncomment this if you need to return PVs
+ case PERL_constant_ISPV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, strlen(pv));
+ break; */
+ /* Uncomment this if you need to return PVNs
+ case PERL_constant_ISPVN:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, iv);
+ break; */
+ /* Uncomment this if you need to return SVs
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break; */
+ /* Uncomment this if you need to return UNDEFs
+ case PERL_constant_ISUNDEF:
+ break; */
+ /* Uncomment this if you need to return UVs
+ case PERL_constant_ISUV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHu((UV)iv);
+ break; */
+ /* Uncomment this if you need to return YESs
+ case PERL_constant_ISYES:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_yes);
+ break; */
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing CGI::Deurl::XS macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
55 fallback/const-c.inc
@@ -0,0 +1,55 @@
+#define PERL_constant_NOTFOUND 1
+#define PERL_constant_NOTDEF 2
+#define PERL_constant_ISIV 3
+#define PERL_constant_ISNO 4
+#define PERL_constant_ISNV 5
+#define PERL_constant_ISPV 6
+#define PERL_constant_ISPVN 7
+#define PERL_constant_ISSV 8
+#define PERL_constant_ISUNDEF 9
+#define PERL_constant_ISUV 10
+#define PERL_constant_ISYES 11
+
+#ifndef NVTYPE
+typedef double NV; /* 5.6 and later define NVTYPE, and typedef NV to it. */
+#endif
+#ifndef aTHX_
+#define aTHX_ /* 5.6 or later define this for threading support. */
+#endif
+#ifndef pTHX_
+#define pTHX_ /* 5.6 or later define this for threading support. */
+#endif
+
+static int
+constant (pTHX_ const char *name, STRLEN len) {
+ /* Initially switch on the length of the name. */
+ /* When generated this function returned values for the list of names given
+ in this section of perl code. Rather than manually editing these functions
+ to add or remove constants, which would result in this comment and section
+ of code becoming inaccurate, we recommend that you edit this section of
+ code, and use it to regenerate a new set of constant functions which you
+ then use to replace the originals.
+
+ Regenerate these constant functions by feeding this entire source file to
+ perl -x
+
+#!/usr/bin/perl -w
+use ExtUtils::Constant qw (constant_types C_constant XS_constant);
+
+my $types = {map {($_, 1)} qw()};
+my @names = (qw());
+
+print constant_types(); # macro defs
+foreach (C_constant ("CGI::Deurl::XS", 'constant', 'IV', $types, undef, 3, @names) ) {
+ print $_, "\n"; # C constant subs
+}
+print "#### XS Section:\n";
+print XS_constant ("CGI::Deurl::XS", $types);
+__END__
+ */
+
+ switch (len) {
+ }
+ return PERL_constant_NOTFOUND;
+}
+
87 fallback/const-xs.inc
@@ -0,0 +1,87 @@
+void
+constant(sv)
+ PREINIT:
+#ifdef dXSTARG
+ dXSTARG; /* Faster if we have it. */
+#else
+ dTARGET;
+#endif
+ STRLEN len;
+ int type;
+ /* IV iv; Uncomment this if you need to return IVs */
+ /* NV nv; Uncomment this if you need to return NVs */
+ /* const char *pv; Uncomment this if you need to return PVs */
+ INPUT:
+ SV * sv;
+ const char * s = SvPV(sv, len);
+ PPCODE:
+ type = constant(aTHX_ s, len);
+ /* Return 1 or 2 items. First is error message, or undef if no error.
+ Second, if present, is found value */
+ switch (type) {
+ case PERL_constant_NOTFOUND:
+ sv = sv_2mortal(newSVpvf("%s is not a valid CGI::Deurl::XS macro", s));
+ PUSHs(sv);
+ break;
+ case PERL_constant_NOTDEF:
+ sv = sv_2mortal(newSVpvf(
+ "Your vendor has not defined CGI::Deurl::XS macro %s, used", s));
+ PUSHs(sv);
+ break;
+ /* Uncomment this if you need to return IVs
+ case PERL_constant_ISIV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHi(iv);
+ break; */
+ /* Uncomment this if you need to return NOs
+ case PERL_constant_ISNO:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_no);
+ break; */
+ /* Uncomment this if you need to return NVs
+ case PERL_constant_ISNV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHn(nv);
+ break; */
+ /* Uncomment this if you need to return PVs
+ case PERL_constant_ISPV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, strlen(pv));
+ break; */
+ /* Uncomment this if you need to return PVNs
+ case PERL_constant_ISPVN:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHp(pv, iv);
+ break; */
+ /* Uncomment this if you need to return SVs
+ case PERL_constant_ISSV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(sv);
+ break; */
+ /* Uncomment this if you need to return UNDEFs
+ case PERL_constant_ISUNDEF:
+ break; */
+ /* Uncomment this if you need to return UVs
+ case PERL_constant_ISUV:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHu((UV)iv);
+ break; */
+ /* Uncomment this if you need to return YESs
+ case PERL_constant_ISYES:
+ EXTEND(SP, 1);
+ PUSHs(&PL_sv_undef);
+ PUSHs(&PL_sv_yes);
+ break; */
+ default:
+ sv = sv_2mortal(newSVpvf(
+ "Unexpected return type %d while processing CGI::Deurl::XS macro %s, used",
+ type, s));
+ PUSHs(sv);
+ }
23 parser/Makefile.PL
@@ -0,0 +1,23 @@
+use ExtUtils::MakeMaker;
+$Verbose = 1;
+WriteMakefile(
+ NAME => 'CGI::Deurl::XS::parser',
+ SKIP => [qw(all static dynamic )],
+ clean => {'FILES' => 'libparser$(LIB_EXT)'},
+);
+
+
+sub MY::top_targets {
+'
+all :: static
+
+pure_all :: static
+
+static :: libparser$(LIB_EXT)
+
+libparser$(LIB_EXT): $(O_FILES)
+ $(AR) cr libparser$(LIB_EXT) $(O_FILES)
+ $(RANLIB) libparser$(LIB_EXT)
+
+';
+}
255 parser/parser.c
@@ -0,0 +1,255 @@
+/*
+ * Portions taken from libapreq 1.33.
+ * Copyright 2007 The Apache Software Foundation.
+ * Used under the Apache License v2.0.
+ * http://search.cpan.org/~stas/libapreq-1.33/
+ */
+
+#ifndef __USE_GNU
+#define __USE_GNU
+#endif
+#include <string.h>
+#include <ctype.h>
+#include <stdio.h>
+#include <stdlib.h>
+
+#include "parser.h"
+
+static
+void
+req_plustospace(char* str)
+{
+ register int x;
+ for(x=0;str[x];x++)
+ if(str[x] == '+')
+ str[x] = ' ';
+}
+
+static
+char
+x2c(char* what)
+{
+ register char digit;
+
+ digit = ((what[0] >= 'A') ? ((what[0] & 0xdf) - 'A') + 10 : (what[0] - '0'));
+ digit *= 16;
+ digit += (what[1] >= 'A' ? ((what[1] & 0xdf) - 'A') + 10 : (what[1] - '0'));
+ return digit;
+}
+
+static
+unsigned int
+utf8_convert(char* str)
+{
+ long x = 0;
+ int i = 0;
+ while (i < 4 ) {
+ if ( isxdigit(str[i]) != 0 ) {
+ if( isdigit(str[i]) != 0 ) {
+ x = x * 16 + str[i] - '0';
+ }
+ else {
+ str[i] = tolower( str[i] );
+ x = x * 16 + str[i] - 'a' + 10;
+ }
+ }
+ else {
+ return 0;
+ }
+ i++;
+ }
+ if(i < 3)
+ return 0;
+ return (x);
+}
+
+static
+int
+unescape_url_u(char* url)
+{
+ register int x, y, badesc, badpath;
+
+ badesc = 0;
+ badpath = 0;
+ for (x = 0, y = 0; url[y]; ++x, ++y) {
+ if (url[y] != '%'){
+ url[x] = url[y];
+ }
+ else {
+ if(url[y + 1] == 'u' || url[y + 1] == 'U'){
+ unsigned int c = utf8_convert(&url[y + 2]);
+ y += 5;
+ if(c < 0x80){
+ url[x] = c;
+ }
+ else if(c < 0x800) {
+ url[x] = 0xc0 | (c >> 6);
+ url[++x] = 0x80 | (c & 0x3f);
+ }
+ else if(c < 0x10000){
+ url[x] = (0xe0 | (c >> 12));
+ url[++x] = (0x80 | ((c >> 6) & 0x3f));
+ url[++x] = (0x80 | (c & 0x3f));
+ }
+ else if(c < 0x200000){
+ url[x] = 0xf0 | (c >> 18);
+ url[++x] = 0x80 | ((c >> 12) & 0x3f);
+ url[++x] = 0x80 | ((c >> 6) & 0x3f);
+ url[++x] = 0x80 | (c & 0x3f);
+ }
+ else if(c < 0x4000000){
+ url[x] = 0xf8 | (c >> 24);
+ url[++x] = 0x80 | ((c >> 18) & 0x3f);
+ url[++x] = 0x80 | ((c >> 12) & 0x3f);
+ url[++x] = 0x80 | ((c >> 6) & 0x3f);
+ url[++x] = 0x80 | (c & 0x3f);
+ }
+ else if(c < 0x8000000){
+ url[x] = 0xfe | (c >> 30);
+ url[++x] = 0x80 | ((c >> 24) & 0x3f);
+ url[++x] = 0x80 | ((c >> 18) & 0x3f);
+ url[++x] = 0x80 | ((c >> 12) & 0x3f);
+ url[++x] = 0x80 | ((c >> 6) & 0x3f);
+ url[++x] = 0x80 | (c & 0x3f);
+ }
+ }
+ else {
+ if (!isxdigit(url[y + 1]) || !isxdigit(url[y + 2])) {
+ badesc = 1;
+ url[x] = '%';
+ }
+ else {
+ url[x] = x2c(&url[y + 1]);
+ y += 2;
+ if (url[x] == '/' || url[x] == '\0')
+ badpath = 1;
+ }
+ }
+ }
+ }
+ url[x] = '\0';
+ if (badesc)
+ return 0;
+ else if (badpath)
+ return 0;
+ else
+ return 1;
+}
+
+static
+char*
+_strndup(char* str, size_t len)
+{
+ char *dup = (char*) malloc(len+1);
+ if (dup) {
+ strncpy(dup, str, len);
+ dup[len] = '\0';
+ }
+ return dup;
+}
+
+
+static
+char*
+urlword(char** line)
+{
+ char* res = 0;
+ char* pos = *line;
+ char ch;
+
+ while ( (ch = *pos) != '\0' && ch != ';' && ch != '&') {
+ ++pos;
+ }
+
+ res = _strndup(*line, pos - *line);
+
+ while (ch == ';' || ch == '&') {
+ ++pos;
+ ch = *pos;
+ }
+
+ *line = pos;
+
+ return res;
+}
+
+char*
+getword(char** line, char stop)
+{
+ char* pos = *line;
+ int len;
+ char* res;
+
+ while ((*pos != stop) && *pos) {
+ ++pos;
+ }
+
+ len = pos - *line;
+ res = (char*)malloc(len + 1);
+ memcpy(res, *line, len);
+ res[len] = 0;
+
+ if (stop) {
+ while (*pos == stop) {
+ ++pos;
+ }
+ }
+ *line = pos;
+
+ return res;
+}
+
+SV*
+_split_to_parms(char* data)
+{
+ char* val;
+ HV* hash = 0;
+
+ while (*data && (val = urlword(&data))) {
+ char* val_orig = val;
+ char* key = getword(&val, '=');
+
+ req_plustospace((char*)key);
+ unescape_url_u((char*)key);
+ req_plustospace((char*)val);
+ unescape_url_u((char*)val);
+
+ if (!hash) {
+ hash = newHV();
+ }
+
+ int klen = strlen(key);
+ SV* newval = newSVpv(val, 0);
+
+ if (hv_exists(hash, key, klen)) {
+ /* this param already exists */
+
+ SV** entry = hv_fetch(hash, key, klen, 0);
+ if (!entry) {
+ return 0;
+ }
+
+ if (SvROK(*entry) && SvTYPE(SvRV(*entry)) == SVt_PVAV) {
+ /* already an arrayref, just push to the end */
+ av_push((AV*) SvRV(*entry), newval);
+ }
+ else {
+ /* just a scalar; wrap the new and old values in an arrayref */
+ SV* values[2] = { *entry, newval };
+ AV* array = av_make(2, values); /* this copies the SVs... */
+ SvREFCNT_dec(newval); /* ... so destroy the original. */
+ SV* aref = newRV_noinc((SV*) array); /* create an array ref... */
+ hv_store(hash, key, klen, aref, 0); /* ... and stash it in the hash */
+ }
+ }
+ else {
+ /* no existing param, pop this one in */
+ hv_store(hash, key, klen, newval, 0);
+ }
+
+ free(key);
+ free(val_orig);
+ }
+
+ return hash ? newRV_noinc((SV*) hash) : 0;
+}
10 parser/parser.h
@@ -0,0 +1,10 @@
+#ifndef _PARSER_H
+#define _PARSER_H
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+SV* _split_to_parms(char*);
+
+#endif /* _PARSER_H */
4,812 ppport.h
4,812 additions, 0 deletions not shown
66 t/CGI-Deurl-XS.t
@@ -0,0 +1,66 @@
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl CGI-Deurl-XS.t'
+
+#########################
+
+use Test::More tests => 25;
+use_ok('CGI::Deurl::XS');
+
+#########################
+
+use CGI::Deurl::XS qw/parse_query_string/;
+
+is(defined parse_query_string(''), '', 'null');
+is(defined parse_query_string('f'), 1, 'defined_anything');
+
+{
+ my $foobar = parse_query_string('foo=bar');
+ is(defined $foobar, 1, 'defined_pair');
+ is(ref($foobar), 'HASH', 'is_hash');
+ my @keys = keys %$foobar;
+ is(scalar @keys, 1, 'single');
+ is($keys[0], 'foo', 'foo');
+ is($foobar->{$keys[0]}, 'bar', 'bar');
+}
+
+# basic use
+{
+ my $foobar = parse_query_string('foo=1&bar=2');
+ my @keys = sort keys %$foobar;
+ is(scalar @keys, 2, 'double');
+ is($keys[1], 'foo', 'foo_key');
+ is($keys[0], 'bar', 'bar_key');
+ is($foobar->{foo}, '1', 'foo_val');
+ is($foobar->{bar}, '2', 'bar_val');
+}
+
+# two or more of same key creates an arrayref
+{
+ my $multi = parse_query_string('foo=1&bar=2&foo=3');
+ is(exists $multi->{foo}, 1, 'multi_exists');
+ is(ref($multi->{foo}), 'ARRAY', 'multi_array');
+ my @vals = @{ $multi->{foo} };
+ is(scalar @vals, 2, 'multi_2vals');
+ is($vals[0], 1, 'multi_2key_a');
+ is($vals[1], 3, 'multi_2key_b');
+}
+
+# adding to existing arrayref uses different codepath, try it too
+{
+ my $multi = parse_query_string('foo=1&bar=2&foo=3&foo=4');
+ my @vals = @{ $multi->{foo} };
+ is(scalar @vals, 3, 'multi_3vals');
+ is($vals[0], 1, 'multi_2key_a');
+ is($vals[1], 3, 'multi_2key_b');
+ is($vals[2], 4, 'multi_2key_c');
+}
+
+is(parse_query_string("foo=b+ar")->{foo}, 'b ar', 'space');
+
+is(parse_query_string("foo=ba\%72")->{foo}, 'bar', 'escape_a');
+
+# unicode
+{
+use encoding 'utf8';
+is(parse_query_string("foo=bar\%u1000")->{foo}, "bar\x{1000}", 'escape_u');
+}
Please sign in to comment.
Something went wrong with that request. Please try again.