From 213033db33be271791f2d9ff1c9c44c0bed79f18 Mon Sep 17 00:00:00 2001 From: Paul Buetow Date: Sun, 6 Mar 2011 10:57:41 +0000 Subject: initial xerl import to utils --- COPYING | 28 +++++ Makefile | 32 ++++++ README | 68 ++++++++++++ STYLEGUIDE | 71 +++++++++++++ TODO | 10 ++ Xerl.pm | 98 ++++++++++++++++++ Xerl/.htaccess | 0 Xerl/Base.pm | 130 +++++++++++++++++++++++ Xerl/Main/Global.pm | 97 ++++++++++++++++++ Xerl/Page/Configure.pm | 165 +++++++++++++++++++++++++++++ Xerl/Page/Content.pm | 226 ++++++++++++++++++++++++++++++++++++++++ Xerl/Page/Document.pm | 71 +++++++++++++ Xerl/Page/Menu.pm | 128 +++++++++++++++++++++++ Xerl/Page/Parameter.pm | 72 +++++++++++++ Xerl/Page/Request.pm | 70 +++++++++++++ Xerl/Page/Rules.pm | 95 +++++++++++++++++ Xerl/Page/Templates.pm | 262 +++++++++++++++++++++++++++++++++++++++++++++++ Xerl/Plugins/Session.pm | 127 +++++++++++++++++++++++ Xerl/Tools/FileIO.pm | 186 +++++++++++++++++++++++++++++++++ Xerl/XML/Element.pm | 111 ++++++++++++++++++++ Xerl/XML/Reader.pm | 195 +++++++++++++++++++++++++++++++++++ config.txt | 24 +++++ index.pl | 10 ++ scripts/modules/file.pm | 54 ++++++++++ scripts/mreplace.sh | 12 +++ scripts/replace.sh | 6 ++ scripts/stats.pl | 92 +++++++++++++++++ scripts/stats/calc.sh | 49 +++++++++ scripts/stats/clean.sh | 49 +++++++++ scripts/stats/replace.sh | 11 ++ scripts/stats/stats.sh | 61 +++++++++++ 31 files changed, 2610 insertions(+) create mode 100644 COPYING create mode 100644 Makefile create mode 100644 README create mode 100644 STYLEGUIDE create mode 100644 TODO create mode 100644 Xerl.pm create mode 100644 Xerl/.htaccess create mode 100644 Xerl/Base.pm create mode 100644 Xerl/Main/Global.pm create mode 100644 Xerl/Page/Configure.pm create mode 100644 Xerl/Page/Content.pm create mode 100644 Xerl/Page/Document.pm create mode 100644 Xerl/Page/Menu.pm create mode 100644 Xerl/Page/Parameter.pm create mode 100644 Xerl/Page/Request.pm create mode 100644 Xerl/Page/Rules.pm create mode 100644 Xerl/Page/Templates.pm create mode 100644 Xerl/Plugins/Session.pm create mode 100644 Xerl/Tools/FileIO.pm create mode 100644 Xerl/XML/Element.pm create mode 100644 Xerl/XML/Reader.pm create mode 100644 config.txt create mode 100755 index.pl create mode 100644 scripts/modules/file.pm create mode 100755 scripts/mreplace.sh create mode 100755 scripts/replace.sh create mode 100644 scripts/stats.pl create mode 100755 scripts/stats/calc.sh create mode 100755 scripts/stats/clean.sh create mode 100755 scripts/stats/replace.sh create mode 100755 scripts/stats/stats.sh diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..be5ae5e --- /dev/null +++ b/COPYING @@ -0,0 +1,28 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.perl9.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..a9c9285 --- /dev/null +++ b/Makefile @@ -0,0 +1,32 @@ +all: stats +clean: + rm -Rf cache/* +stats: clean + perl scripts/stats.pl +replace: + for i in index.pl Xerl.pm conf.txt; \ + do \ + sed -n "s/$(FROM)/$(INTO)/g; \ + w .tmp" $$i && mv -f .tmp $$i; \ + done + find ./Xerl -name '*.pm' -exec sh -c 'sed -n "s/$(FROM)/$(INTO)/g; \ + w .tmp" {} && mv -f .tmp {}' \; + find ./Xerl -name '*.pl' -exec sh -c 'sed -n "s/$(FROM)/$(INTO)/g; \ + w .tmp" {} && mv -f .tmp {}' \; + find ./Xerl -name '*.log' -exec sh -c 'sed -n "s/$(FROM)/$(INTO)/g; \ + w .tmp" {} && mv -f .tmp {}' \; + find ./Xerl -name '*.xml' -exec sh -c 'sed -n "s/$(FROM)/$(INTO)/g; \ + w .tmp" {} && mv -f .tmp {}' \; + chmod 755 index.pl +pidy: + find . -name \*.pl | xargs perltidy -b + find . -name \*.pm | xargs perltidy -b + find . -name \*.bak | xargs rm -f +todo: + grep -R TODO . | grep -v Makefile | grep -v .svn +warn: + perl index.pl 2> warnings + less warnings + rm -f warnings +kb: + find . -name '*.pm' -exec du -hs {} \; | awk 'BEGIN{kb=0}{kb+=$$1}END{print kb}' diff --git a/README b/README new file mode 100644 index 0000000..7a6d984 --- /dev/null +++ b/README @@ -0,0 +1,68 @@ +Always do: + +- Pragmatic modules ALWAYS to use in ALL packages: + + use strict; + use warnings; + +- Only for packages for including package UNIVERSAL definitions + + use Xerl::Page::Base; + +- Object oriented coding style + +- Always use method prototypes if possible + + sub foo($;$) { .... } + +- Explicit object typing if possible + + my Class::Name::Here $foo = Class::Name::Here->new(); + +- If no real ret val, set undef; explicitly + + sub foo() { + # Do some stuff + ... + # Set explicit undef ret value + return undef; + } + +- Private subs use _ as its prefix and are called only from the current package. + + package Xerl::Foo::Bla; + . + . + + sub _iamprivate($) { + my Xerl::Foo:Bla $self = $_[0]; + . + . + } + + sub iampublic($) { + my Xerl::Foo:Bla $self = $_[0]; + $self->_iamprivate(); + return undef; + } + +- Static subs (not OOP) are in CAPITAL letters. + + sub IAMSTATIC($) { + print shift; + return 'Hello World'; + } + + sub iamdynamic($) { + my Xerl::Foo:Bla $self = $_[0]; + return Xerl::Foo::Bla::IAMSTATIC( $self->get_somevalue() ); + } + +- Static private subs start with _ and are written in CAPITAL letters + + sub _IAMSTATICPRIVATE() { + . + . + } + +- Use Pidy to automaically restyle the code! (make pidy) diff --git a/STYLEGUIDE b/STYLEGUIDE new file mode 100644 index 0000000..e6dd3c9 --- /dev/null +++ b/STYLEGUIDE @@ -0,0 +1,71 @@ +Always do: + +- Pragmatic modules ALWAYS to use in ALL packages: + + use strict; + use warnings; + +- Only for packages for including package UNIVERSAL definitions + + use Xerl::Page::Base; + +- Object oriented coding style + +- Always use method prototypes if possible + + sub foo($;$) { .... } + +- Explicit object typing if possible + + my Class::Name::Here $foo = Class::Name::Here->new(); + +- If no real ret val, set undef; explicitly + + sub foo() { + # Do some stuff + ... + # Set explicit undef ret value + return undef; + } + +- Private subs use _ as its prefix and are called only from the current package. + + package Xerl::Foo::Bla; + . + . + + sub _iamprivate($) { + my Xerl::Foo:Bla $self = $_[0]; + . + . + } + + sub iampublic($) { + my Xerl::Foo:Bla $self = $_[0]; + $self->_iamprivate(); + return undef; + } + +- Static subs (not OOP) are in CAPITAL letters. + + sub IAMSTATIC($) { + print shift; + return 'Hello World'; + } + + sub iamdynamic($) { + my Xerl::Foo:Bla $self = $_[0]; + return Xerl::Foo::Bla::IAMSTATIC( $self->get_somevalue() ); + } + +- Static private subs start with _ and are written in CAPITAL letters + + sub _IAMSTATICPRIVATE() { + . + . + } + +- Use Pidy to automaically restyle the code! (make pidy) + +- Mark things which are still to do with TODO: at any place in the source + tree. (Can be searched for using 'make todo'). diff --git a/TODO b/TODO new file mode 100644 index 0000000..e28d513 --- /dev/null +++ b/TODO @@ -0,0 +1,10 @@ +Hint: Run 'make todo' to see everything in every file what is to do! + +TODO: - Caching of config.xml +TODO: - Documentation of all features/options +TODO: - Fix bug +TODO: - Global conf.txt -> config.xml, host specific config is in XML already +TODO: - Include new config.xml in config.xml if exists +TODO: - Inline perl in template.xml! +TODO: - Login area (cookies are working already) +TODO: - Rename Plugins -> Extensions diff --git a/Xerl.pm b/Xerl.pm new file mode 100644 index 0000000..bade547 --- /dev/null +++ b/Xerl.pm @@ -0,0 +1,98 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl; + +use strict; +use warnings; + +use CGI::Carp 'fatalsToBrowser'; +use Time::HiRes 'gettimeofday'; + +use Xerl::Base; +use Xerl::Main::Global; +use Xerl::Page::Configure; +use Xerl::Page::Document; +use Xerl::Page::Parameter; +use Xerl::Page::Request; +use Xerl::Page::Templates; +use Xerl::Plugins::Session; + +sub run($) { + my Xerl $self = $_[0]; + my $time = [gettimeofday]; + + my Xerl::Page::Request $request = + Xerl::Page::Request->new( request => $ENV{REQUEST_URI} ); + + $request->parse(); + my Xerl::Page::Configure $config = + Xerl::Page::Configure->new( config => $self->get_config(), %$request ); + + $config->parse(); + + # TODO: Plugin API + unless ( $config->sessionsdisable_exists() ) { + my Xerl::Plugins::Session $session = + Xerl::Plugins::Session->new( config => $config ); + + $session->process(); + $config->set_session($session); + } + + my Xerl::Page::Parameter $parameter = + Xerl::Page::Parameter->new( config => $config ); + + $parameter->parse(); + + if ( $config->document_exists() ) { + my Xerl::Page::Document $document = + Xerl::Page::Document->new( config => $config ); + + $document->parse(); + + } + else { + my Xerl::Page::Templates $templates = + Xerl::Page::Templates->new( config => $config ); + + $templates->parse(); + $templates->print($time); + } + + + # This function gets always called if the scripts ends. + # The script may also end on another location. + Xerl::Main::Global::SHUTDOWN(); + + # Never reach this point + return undef; +} + +1; diff --git a/Xerl/.htaccess b/Xerl/.htaccess new file mode 100644 index 0000000..e69de29 diff --git a/Xerl/Base.pm b/Xerl/Base.pm new file mode 100644 index 0000000..ebb1494 --- /dev/null +++ b/Xerl/Base.pm @@ -0,0 +1,130 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package UNIVERSAL; + +use strict; +use warnings; + +sub new ($;) { + my $self = shift; + + bless {@_} => $self; +} + +sub setval($$$) { + my UNIVERSAL $self = $_[0]; + + $self->{ $_[1] } = $_[2]; + + return undef; +} + +sub getval($$) { + my UNIVERSAL $self = $_[0]; + + return defined $self->{ $_[1] } ? $self->{ $_[1] } : ''; +} + +sub exists($$) { + my UNIVERSAL $self = $_[0]; + + return exists $self->{ $_[1] } ? 1 : 0; +} + +sub AUTOLOAD { + my UNIVERSAL $self = $_[0]; + my $auto = our $AUTOLOAD; + return $self if $auto =~ /DESTROY/; + + if ( $auto =~ /.*::set_(.+)$/ ) { + $self->{$1} = $_[1]; + + } + elsif ( $auto =~ /.*::get_(.+)_ref$/ ) { + return defined $self->{$1} ? \$self->{$1} : ['']; + + } + elsif ( $auto =~ /.*::get_(.+)$/ ) { + return defined $self->{$1} ? $self->{$1} : ''; + + } + elsif ( $auto =~ /.*::undef_(.+)$/ ) { + return '' unless defined $self->{$1}; + + my $retval = $self->{$1}; + undef $self->{$1}; + return $retval; + + } + elsif ( $auto =~ /.*::append_(.+)$/ ) { + if ( defined $self->{$1} ) { + $self->{$1} .= $_[1]; + + } + else { + $self->{$1} = $_[1]; + } + + } + elsif ( $auto =~ /.*::push_(.+)$/ ) { + if ( exists $self->{$1} ) { + push @{ $self->{$1} }, $_[1]; + + } + else { + $self->{$1} = [ $_[1] ]; + } + + } + elsif ( $auto =~ /.*::first_(.+)$/ ) { + return exists $self->{$1} ? ${ $self->{$1} }[0] : ''; + + } + elsif ( $auto =~ /.*::(.+)_exists$/ ) { + return exists $self->{$1} ? 1 : 0; + + } + elsif ( $auto =~ /.*::(.+)_length$/ ) { + return ( ref $self->{$1} eq 'ARRAY' ) ? scalar @{ $self->{$1} } : 0; + + } + elsif ( $auto =~ /.*::(.+)_isset$/ ) { + return exists $self->{$1} ? $self->{ $_[0] } : 0; + + } + else { + print "$auto is not a method of $self or UNIVERSAL\n"; + } + + return $self; +} + +1; + diff --git a/Xerl/Main/Global.pm b/Xerl/Main/Global.pm new file mode 100644 index 0000000..0ca2357 --- /dev/null +++ b/Xerl/Main/Global.pm @@ -0,0 +1,97 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Main::Global; + +sub SHUTDOWN { + exit 0; + + # Never reach this point + return undef; +} + +sub DEBUG { + print 'Debug::', @_, "\n"; + + return undef; +} + +sub ERROR { + print "Content-Type: text/plain\n\nXerl runtime error: ", + join( ' ', time, @_ ); + + Xerl::Main::Global::SHUTDOWN(); + + # Never reach this point + return undef; +} + +sub PLAIN { + print "Content-Type: text/plain\n\n"; + + DEBUG(@_) if @_; + + return undef; +} + +sub REDIRECT ($) { + my $location = shift; + print "Status: 301 Moved Permanantly\n"; + print "Location: $location\n\n"; + + Xerl::Main::Global::SHUTDOWN(); + + return undef; +} + +sub _HTTP_DESCR ($) { + my $status = shift; + + if ( $status == 404 ) { + "Status: 404 Not Found\015\012\n\n" + + } + else { + "Status: 405 Method not allowed\015\012\n\n"; + } +} + +sub HTTP { + my $descr = _HTTP_DESCR(shift); + print $descr; + local $, = ' '; + print $descr; + + Xerl::Main::Global::SHUTDOWN(); + + # Never reach this point + return undef; +} + +1; diff --git a/Xerl/Page/Configure.pm b/Xerl/Page/Configure.pm new file mode 100644 index 0000000..a1a5e74 --- /dev/null +++ b/Xerl/Page/Configure.pm @@ -0,0 +1,165 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Page::Configure; + +use strict; +use warnings; + +use Xerl::Base; +use Xerl::Tools::FileIO; +use Xerl::XML::Element; + +sub parse($) { + my Xerl::Page::Configure $self = $_[0]; + + my Xerl::Tools::FileIO $file = + Xerl::Tools::FileIO->new( 'path' => $self->get_config() ); + + $file->fslurp(); + + my $re = qr/^(.+?) *=(.+?) *\n?$/; + + for ( @{ $file->get_array() } ) { + next if /^ *#/; + + $self->setval( $1, $self->eval($2) ) if $_ =~ $re; + } + + return $self; +} + +sub defaults($) { + my Xerl::Page::Configure $self = $_[0]; + + $self->set_proto('https') if exists $ENV{HTTPS}; + + $self->set_site( $self->get_defaultcontent() ) + unless $self->site_exists(); + + $self->set_nsite( $self->get_site() =~ /^(?:\d*\.)?(.*)/ ); + + $self->set_template( $self->get_defaulttemplate() ) + unless $self->template_exists(); + + $self->set_style( $self->get_defaultstyle() ) + unless $self->style_exists(); + + $self->set_proto( $self->get_defaultproto() ) + unless $self->proto_exists(); + + $self->set_host( lc $ENV{HTTP_HOST} ) + unless $self->host_exists(); + + unless ( -d $self->get_hostroot() . $self->get_host() ) { + my $redirect = $self->get_hostroot() . 'redirect:' . $self->get_host(); + if ( -f $redirect ) { + my Xerl::Tools::FileIO $file = + Xerl::Tools::FileIO->new( 'path' => $redirect ); + $file->fslurp(); + my $location = $file->shift(); + Xerl::Main::Global::REDIRECT($location); + } + my $alias = $self->get_hostroot() . 'alias:' . $self->get_host(); + if ( -f $alias ) { + my Xerl::Tools::FileIO $file = + Xerl::Tools::FileIO->new( 'path' => $alias ); + $file->fslurp(); + $self->set_host( $file->shift() ); + } + } + + $self->set_outputformat( $self->get_defaultoutputformat() ) + unless $self->outputformat_exists(); + + if ( $self->format_exists() ) { + $self->set_outputformat( $self->get_format() ); + $self->set_template( $self->get_format() ); + $self->set_site( $self->get_format() ); + $self->set_nocache(1) + if $self->get_format() =~ /\.feed$/; + } + + $self->set_host( $self->getval( $self->get_host() ) ) + if $self->exists( $self->get_host() ); + + $self->set_host( $self->getval( $self->get_host() ) ) + if $self->exists( $self->get_host() ); + + my $request_subdir = $self->get_request_subdir(); + $self->set_hostpath( + $self->get_hostroot() . $self->get_host() . $request_subdir . "/" ); + + $self->set_defaulthostpath( + $self->get_hostroot() . $self->get_defaulthost() . '/' ); + + $self->set_cachepath( + $self->get_cacheroot() . $self->get_host() . $request_subdir . '/' ); + + $self->set_htdocspath( $self->get_hostpath() . 'htdocs/' ); + + $self->set_templatespath( $self->get_hostpath() . 'templates/' ); + + $self->set_contentpath( $self->get_hostpath() . 'content/' ); + + return undef; +} + +sub eval($$) { + my Xerl::Page::Configure $self = $_[0]; + my $val = $_[1]; + + $val =~ s/^!(.+)/`$1`/eo; + return $val; +} + +sub insertxmlvars($$) { + my Xerl::Page::Configure $self = $_[0]; + my Xerl::XML::Element $element = $_[1]; + + $element = $element->starttag('variables'); + + return $self + unless defined $element + or $element->get_array() eq 'ARRAY'; + + my $text; + for ( @{ $element->get_array() } ) { + $text = $_->get_text(); + chomp $text; + + $text =~ s/%%(.*?)%%/$self->getval($1)/eg; + $self->setval( $_->get_name(), $text ); + } + + return $self; +} + +1; + diff --git a/Xerl/Page/Content.pm b/Xerl/Page/Content.pm new file mode 100644 index 0000000..bea97c7 --- /dev/null +++ b/Xerl/Page/Content.pm @@ -0,0 +1,226 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Page::Content; + +use strict; +use warnings; + +use Xerl::Base; + +use Xerl::XML::Reader; +use Xerl::XML::Element; +use Xerl::Page::Rules; +use Xerl::Page::Configure; + +sub parse($) { + my Xerl::Page::Content $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + + my Xerl::XML::Reader $xmlcontent = Xerl::XML::Reader->new( + path => $config->get_templatepath(), + config => $config + ); + + $xmlcontent->open(); + $xmlcontent->parse(); + + my Xerl::Page::Rules $rules = Xerl::Page::Rules->new( config => $config ); + $rules->parse( $config->get_xmlconfigrootobj() ) + unless $config->exists('noparse'); + + $config->insertxmlvars( $config->get_xmlconfigrootobj() ); + $self->insertrules( $rules, $xmlcontent->get_root() ); + + return undef; +} + +sub insertrules($$$$) { + my Xerl::Page::Content $self = $_[0]; + my Xerl::Page::Rules $rules = $_[1]; + my Xerl::XML::Element $element = $_[2]; + + # Start inserting rules at + $element = $element->starttag('content'); + + # If there is no -tag, dont use a rule! + return unless defined $element; + + my @content; + my $params = $element->get_params(); + + unshift @content, "Content-Type: $params->{type}\n\n" + if ref $params eq 'HASH' and exists $params->{type}; + + push @content, $self->_insertrules( $rules, $element ); + $self->set_content( \@content ); + + return undef; +} + +sub _insertrules($$$) { + my Xerl::Page::Content $self = $_[0]; + my Xerl::Page::Rules $rules = $_[1]; + my Xerl::XML::Element $element = $_[2]; + my Xerl::Page::Configure $config = $self->get_config(); + my $nonewlines = 0; + + #$element->print(); + # + # Don't interate through the XML childs if we have a leaf node. + return () unless ref $element->get_array() eq 'ARRAY'; + my ( $name, $rule, @content, $text, $params ); + + for my $succ ( @{ $element->get_array() } ) { + $name = $succ->get_name(); + $text = $succ->get_text(); + $params = $succ->get_params(); + + # Remove leading and ending whitespaces, also ending newlines. + $text =~ s/^ *(.*)( |\n)*$/$1/g; + unless ( ref( $rule = $rules->getval($name) ) eq 'ARRAY' ) { + if ( lc $name eq 'noop' ) { + if ( ref $succ->get_array() eq 'ARRAY' ) { + push @content, $self->_insertrules( $rules, $succ ); + + } + else { + push @content, "$text\n"; + } + + } + elsif ( lc $name eq 'tag' ) { + push @content, "<$text>\n"; + + } + elsif ( lc $name eq 'perl' ) { + + # Perl content will be interpreted by Xerl::Page::Templates::print later + push @content, '', $text, ''; + + } + elsif ( lc $name eq 'navigation' ) { + my $menus = $config->get_menuobj()->get_array(); + + if ( ref $menus eq 'ARRAY' ) { + push @content, $self->_insertrules( $rules, $_ ) + for @$menus; + } + + } + else { + + # No rule available, use the tag unmodified! + $name =~ s/^=//o; # Remove the leading = + if ( $succ->get_single() ) { + push @content, + "<$name" + . ( $succ->params_str() || '' ) . " />\n" + + } + else { + push @content, + "<$name" . ( $succ->params_str() || '' ) . '>', + $self->_insertrules( $rules, $succ ), $text, "\n"; + } + } + + } + else { + + # Get a local copy of lrule, because orule may be modified. + # And then insert special vars if required: + # @@text@@ => Text content of the current tag. + + my $ruleparams = $rule->[2]; + $nonewlines = 1 if exists $ruleparams->{nonewlines}; + + my ( $orule, $crule ) = ( $rule->[0], $rule->[1] ); + + $self->_insert_special_vars( $rules, $succ, \$orule ); + $self->_insert_special_vars( $rules, $succ, \$crule ); + chomp $orule; + + # Parse for known tag params. + if ( ref $params eq 'HASH' ) { + Xerl::Page::Templates::PARSELINE( $config, '%%', \$text ); + + # path/to/file.bla => file.bla + $text =~ s#.*/(.*)$#$1# if lc $params->{basename} eq 'yes'; + + # foo.bar.tld?options => ?options + if ( exists $params->{cut} ) { + my $cut = quotemeta $params->{cut}; + $text =~ s/.*$cut(.*)$/$1/o; + } + + $text .= $params->{addback} + if exists $params->{addback}; + $text = $params->{addfront} . $text + if exists $params->{addfront}; + } + + my $oadd = + exists $ruleparams->{addfront} + ? '<' . $ruleparams->{addfront} + : ''; + + my $cadd = + exists $ruleparams->{addback} ? $ruleparams->{addback} . '>' : ''; + + push @content, $orule, $oadd, $self->_insertrules( $rules, $succ ), + $text, $cadd, $crule; + } + } + + return $nonewlines ? map { s/\n/ /go; $_ } @content : @content; +} + +sub _insert_special_vars($$$$) { + my Xerl::Page::Content $self = $_[0]; + my Xerl::Page::Rules $rules = $_[1]; + my Xerl::XML::Element $element = $_[2]; + my Xerl::Page::Configure $config = $self->get_config(); + my $rtext = $_[3]; + + $$rtext =~ s/@\@text\@\@/$_=$element->get_text();chomp;$_/geo; + $$rtext =~ s/@\@ln\@\@//go; + + #$$rtext =~ s/@\@link\@\@/$element->get_params()->{link}.'$$params$$'/geo; + + if ( $$rtext =~ /@\@(.*?)\@\@/ ) { + my $params = $element->get_params(); + return unless ref $params eq 'HASH'; + $$rtext =~ s/@\@(.*?)\@\@/$params->{$1}||''/geo; + } + + return undef; +} + +1; diff --git a/Xerl/Page/Document.pm b/Xerl/Page/Document.pm new file mode 100644 index 0000000..e2aacb1 --- /dev/null +++ b/Xerl/Page/Document.pm @@ -0,0 +1,71 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Page::Document; + +use strict; +use warnings; + +use Xerl::Base; +use Xerl::Main::Global; +use Xerl::Page::Configure; +use Xerl::Tools::FileIO; + +sub parse($) { + my Xerl::Page::Document $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + + return undef unless $config->document_exists(); + + my $document = $config->get_document(); + my ($filename) = $document =~ m#([^/]+)$#; + my ($postfix) = $document =~ /\.(.+)$/; + my $path; + + print 'Content-Type: '; + print $config->getval( 'ctype.' . lc($postfix) ), "\n"; + print "Content-Disposition: attachment; filename=\"$filename\"\n\n"; + + $path = $config->get_hostpath() . "/htdocs/$document"; + unless ( -f $path ) { + $path = + $config->get_hostroot() + . $config->get_defaulthost() + . "/htdocs/$document"; + } + + my Xerl::Tools::FileIO $io = Xerl::Tools::FileIO->new( path => $path ); + + $io->fslurp(); + $io->print(); + + return undef; +} + +1; diff --git a/Xerl/Page/Menu.pm b/Xerl/Page/Menu.pm new file mode 100644 index 0000000..b835148 --- /dev/null +++ b/Xerl/Page/Menu.pm @@ -0,0 +1,128 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Page::Menu; + +use strict; +use warnings; + +use Xerl::Page::Configure; +use Xerl::Tools::FileIO; +use Xerl::XML::Element; + +sub generate($;$) { + my Xerl::Page::Menu $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + + my @site = split /\//, $config->get_site(); + my @compare = @site; + my $site = pop @site; + + my ( $content, $siteadd ) = ( 'content/', '' ); + + my Xerl::XML::Element $menuelem = + $self->get_menu( $content, $siteadd, shift @compare ); + + $self->push_array($menuelem) + if $menuelem->first_array()->array_length() > 1; + + for my $s (@site) { + $content .= "$s.sub/"; + $siteadd .= "$s/"; + $menuelem = $self->get_menu( $content, $siteadd, shift @compare ); + $self->push_array($menuelem) + if $menuelem->first_array()->array_length() > 1; + } + + return undef; +} + +sub get_menu($$$$) { + my Xerl::Page::Menu $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + my ( $content, $siteadd, $compare ) = ( @_[ 1 ... 2 ], lc $_[3] ); + my $issubsection = $content =~ m{\.sub/$}; + my $pattern = qr/\.(?:xml)|(?:sub)$/; + + my Xerl::Tools::FileIO $io = Xerl::Tools::FileIO->new( + path => $config->get_hostpath() . $content, + basename => 1, + ); + + Xerl::Main::Global::REDIRECT( $config->get_404() ) unless $io->exists(); + + $io->dslurp(); + my $dir = $io->get_array(); + + my ( @prec, @dir ); + map { + if (/^\d+\..+\./) { push @prec, $_ } + else { push @dir, $_ } + } + grep { + $_ !~ /^home\.xml$/i + && $_ !~ /\.feed\.xml$/i + && $_ !~ /\.hide\.xml$/i + } @$dir; + + my Xerl::XML::Element $root = Xerl::XML::Element->new(); + my Xerl::XML::Element $menu = Xerl::XML::Element->new(); + + $menu->set_name('menu'); + + for ( $issubsection ? ( @dir, @prec ) : ( 'home.xml', @dir, @prec ) ) { + my ($site) = /(.*)$pattern/o; + + $site =~ s#\.$#/home#o; + $site =~ s/^\d+\.//; + + my $linkname = $site; + $linkname =~ s/(?:\d+\.)?(.)/\U$1/o; + $compare .= '/' if $linkname =~ s#(.*/)[^/]+$#$1#; + + my Xerl::XML::Element $item = Xerl::XML::Element->new( + params => { link => "?site=$siteadd$site" }, + text => $linkname + ); + + $compare =~ s/^(\d+\.)//; + $item->set_name( + lc $linkname eq lc $compare ? 'activemenuitem' : 'menuitem' ); + + $item->set_prev($menu); + $menu->push_array($item); + } + + $root->push_array($menu); + $menu->set_prev($root); + + return $root; +} + +1; diff --git a/Xerl/Page/Parameter.pm b/Xerl/Page/Parameter.pm new file mode 100644 index 0000000..2100323 --- /dev/null +++ b/Xerl/Page/Parameter.pm @@ -0,0 +1,72 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Page::Parameter; + +use strict; +use warnings; + +use Xerl::Base; +use Xerl::Main::Global; +use Xerl::Page::Configure; +use Xerl::Tools::FileIO; + +sub parse($) { + my Xerl::Page::Parameter $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + + print "Content-Type: text/plain\n\n" + if $config->plain_exists(); + + if ( $config->href_exists() ) { + print "Location: ", $config->get_href(), "\n\n"; + Xerl::Main::Global::SHUTDOWN(); + + } + elsif ( $config->env_exists() ) { + print "Content-Type: text/plain\n\n"; + print "$_=", $ENV{$_}, "\n" for keys %ENV; + Xerl::Main::Global::SHUTDOWN(); + } + + if ( $config->devel_exists() ) { + $config->set_nolog(1); + $config->set_nocache(1); + } + + if ( $config->conf_exists() ) { + print "Content-Type: text/plain\n\n"; + print "$_=", $config->{$_}, "\n" for keys %$config; + Xerl::Main::Global::SHUTDOWN(); + } + + return $self; +} + +1; diff --git a/Xerl/Page/Request.pm b/Xerl/Page/Request.pm new file mode 100644 index 0000000..007745f --- /dev/null +++ b/Xerl/Page/Request.pm @@ -0,0 +1,70 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Page::Request; + +use strict; +use warnings; + +use Xerl::Base; + +sub parse($) { + my Xerl::Page::Request $self = $_[0]; + my $request = $self->get_request(); + + # Secure it! + $request =~ s#/\.\.##g; + + # Remove last / + $request =~ s#/$##; + + my $request_subdir = $request; + $request_subdir =~ s#/\?.*##; + $self->set_request_subdir($request_subdir); + + # List context returns $1 + ($_) = $request =~ /\?(.+)/; + + return $self unless defined; + + my $params = ''; + for ( split /&/ ) { + + # List context uses ($1,$2) as method args + $self->setval(/(.+?)=(.+)/); + $params .= "&$1=$2" if $1 ne 'site'; + } + + $self->set_params($params); + + return undef; +} + +1; + diff --git a/Xerl/Page/Rules.pm b/Xerl/Page/Rules.pm new file mode 100644 index 0000000..cf24913 --- /dev/null +++ b/Xerl/Page/Rules.pm @@ -0,0 +1,95 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Page::Rules; + +use strict; +use warnings; + +use Xerl::Base; +use Xerl::XML::Element; +use Xerl::Page::Configure; + +sub parse($) { + my Xerl::Page::Rules $self = $_[0]; + my Xerl::XML::Element $element = $_[1]; + my Xerl::Page::Configure $config = $self->get_config(); + + $element = $element->starttag2( 'rules', $config->get_outputformat() ); + return unless defined $element; + + # Open and close rules: + my ( $orule, $crule ); + + # For all available rules in config.xml + for my $rule ( @{ $element->get_array() } ) { + my $params = $rule->get_params(); + + $orule = $rule->get_text(); + chomp $orule; + + $orule =~ s/\[//go; + + unless ( + ref $params eq 'HASH' + && ( lc $params->{end} eq 'yes' + || lc $params->{start} eq 'yes' ) + ) + { + $crule = join '><', reverse split /> *"; + $crule =~ s/<>/>/go; + $crule =~ s//>/go; + $crule .= "\n"; + + } + else { + if ( lc $$params{start} eq 'yes' ) { + $crule = ''; + + } + else { + $crule = $orule; + $orule = ''; + } + $crule .= "\n"; + } + + $params = {} unless ref $params eq 'HASH'; + $self->setval( $rule->get_name(), [ "$orule\n", $crule, $params ] ); + } + + return undef; +} + +1; diff --git a/Xerl/Page/Templates.pm b/Xerl/Page/Templates.pm new file mode 100644 index 0000000..379fbe9 --- /dev/null +++ b/Xerl/Page/Templates.pm @@ -0,0 +1,262 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Page::Templates; + +use strict; +use warnings; + +use Time::HiRes 'tv_interval'; +use Digest::MD5; + +use Xerl::Base; +use Xerl::Page::Configure; +use Xerl::Page::Content; +use Xerl::Page::Menu; +use Xerl::Tools::FileIO; + +use constant RECURSIVE => 1; + +sub parse($) { + my Xerl::Page::Templates $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + + my $site = $config->get_site(); + + my $subpath = $site; + if ( $site =~ s#^.*/(.*)$#$1#o ) { + $subpath =~ s#/[^/]+$#/#; + $subpath =~ s#/#.sub/#go; + + } + else { + $subpath = ''; + } + + my $cachefile = + $config->get_template() . ';' + . $config->get_outputformat() . ';' + . $site + . ( $config->noparse_exists() ? '.noparse' : '' ) + . '.cache'; + + my $cachepath = $config->get_cachepath() . $subpath; + + if ( -f $cachepath . $cachefile + && ( $config->usecache_exists() or not $config->nocache_exists() ) ) + { + + my Xerl::Tools::FileIO $io = + Xerl::Tools::FileIO->new( path => $cachepath . $cachefile ); + + $io->fslurp(); + $self->set_array( $io->get_array() ); + + } + else { + + my $xmlconfigpath = $config->get_hostpath() . 'config.xml'; + + $xmlconfigpath = $config->get_defaulthostpath() . 'config.xml' + unless -f $xmlconfigpath; + + my Xerl::XML::Reader $xmlconfigreader = + Xerl::XML::Reader->new( path => $xmlconfigpath, config => $config ); + + $xmlconfigreader->open(); + $xmlconfigreader->parse(); + $config->set_xmlconfigrootobj( $xmlconfigreader->get_root() ); + + my Xerl::Page::Menu $menu = Xerl::Page::Menu->new( config => $config ); + + $menu->generate(); + $config->set_menuobj($menu); + + if ( $site =~ /^(\d+)\./ ) { + $config->set_templatepath( + $config->get_hostpath() . "content/$subpath$site.xml" ); + } + elsif ( -f $config->get_hostpath() . "content/$subpath$site.xml" ) { + $config->set_templatepath( + $config->get_hostpath() . "content/$subpath$site.xml" ); + } + + # Hidden files + elsif ( -f $config->get_hostpath() . "content/$subpath.$site.xml" ) { + $config->set_templatepath( + $config->get_hostpath() . "content/$subpath.$site.xml" ); + } + else { + my $glob = $config->get_hostpath() . "content/$subpath*.$site.xml"; + eval "(\$glob) = sort <$glob>;"; + $config->set_templatepath($glob); + } + + my Xerl::Page::Content $bodycontent = + Xerl::Page::Content->new( config => $config ); + + $bodycontent->parse(); + + my $templatepath = + $config->get_hostpath() + . "templates/" + . $config->get_template() . '.xml'; + + $templatepath = + $config->get_defaulthostpath() + . "templates/" + . $config->get_template() . '.xml' + unless -f $templatepath; + + $config->set_templatepath($templatepath); + + my Xerl::Page::Content $templatecontent = + Xerl::Page::Content->new( config => $config ); + + $templatecontent->parse(); + + $self->set_array( $templatecontent->get_content() ); + $config->set_content( $bodycontent->get_content() ); + $self->parsetemplate( '%%', RECURSIVE ); + + my Xerl::Tools::FileIO $io = Xerl::Tools::FileIO->new( + path => $cachepath, + filename => $cachefile, + array => $self->get_array(), + ); + + $io->fwrite(); + } + + unless ( $config->nolog_exists() ) { + my @time = localtime; + my $ctx = Digest::MD5->new(); + $ctx->add( $ENV{REMOTE_ADDR} ); + + my Xerl::Tools::FileIO $stats = Xerl::Tools::FileIO->new( + path => $config->get_statsroot(), + filename => sprintf( + "\%02d%02d%02d", $time[5] - 100, $time[4] + 1, $time[3] + ) + . '.log', + array => [ + time() . ' ' + . $ctx->hexdigest() . ' ' + + #. $ENV{REMOTE_ADDR} . ' ' + . $config->get_host() + . $config->get_request_subdir() . ' ' + . $config->get_site() . ' ' + . $ENV{HTTP_USER_AGENT} . "\n" + ], + ); + + $stats->fwriteappend(); + } + + $self->parsetemplate('$$'); # Parsing dynamic vars. + return undef; +} + +sub parsetemplate($$;$) { + my Xerl::Page::Templates $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + my $deepnesslevel = $_[2] || 0; + + return $self if $deepnesslevel == 100; + + my ( $sep, $foundflag ) = quotemeta $_[1]; + + PARSELINE( $config, $sep, \$_, \$foundflag ) for @{ $self->get_array() }; + + return $self->parsetemplate( $_[1], $deepnesslevel + 1 ) + if defined $deepnesslevel > 0 and $foundflag; + + return undef; +} + +# Static sub +sub PARSELINE($$$;$) { + my Xerl::Page::Configure $config = $_[0]; + my ( $sep, $line, $foundflag ) = @_[ 1 .. 3 ]; + + $$line =~ s/$sep(!)?(.+?)$sep/ + defined $1 ? `$2` : + (ref $config->getval($2) eq 'ARRAY') + ? join '', @{$config->getval($2)} : + $config->getval($2)/eg and $$foundflag = 1; + + return undef; +} + +sub print($;$) { + my Xerl::Page::Templates $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + + my ( $code, $flag ) = ( '', 0 ); + my $time = $_[1]; + my $hflag = 1; + + for my $line ( @{ $self->get_array() } ) { + if ( $hflag == 1 && $config->exists('noparse') ) { + $line =~ s#^Content-Type.*#Content-Type: text/plain#i; + $hflag = 0; + } + $line =~ s/ +/ /g; + redo if !$flag and $line =~ s/((?:.|\n)*?)<\/perl>/eval $1/ego; + + if ( !$flag and $line =~ s/(.*)$//o ) { + $code .= $1; + $flag = 1; + + } + elsif ( $line =~ s/^(.*?)<\/perl>/eval $code.$1/eo ) { + ( $code, $flag ) = ( '', 0 ); + redo; + + } + elsif ($flag) { + $line =~ s/^(.*\n)$//o; + $code .= $1; + next; + } + + my $time = defined $time ? sprintf '%1.4f', tv_interval($time) : ''; + + $line =~ s/!!TIME!!/$time/ge; + $line =~ s/!!LT!!//g; + $line =~ s#!!URL\((.+?)\)!!#$1#g; + print $line; + } + + return undef; +} + +1; diff --git a/Xerl/Plugins/Session.pm b/Xerl/Plugins/Session.pm new file mode 100644 index 0000000..bb5382f --- /dev/null +++ b/Xerl/Plugins/Session.pm @@ -0,0 +1,127 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Plugins::Session; + +use strict; +use warnings; + +use CGI; +use CGI::Session; + +use Xerl::Base; +use Xerl::Main::Global; +use Xerl::Page::Configure; + +sub process($) { + my Xerl::Plugins::Session $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + + my CGI $cgi = CGI->new(); + + my CGI::Session $session = do { + my $cookie = $cgi->cookie( -name => 'session' ); + $cookie ? $self->_get_session($cookie) : $self->_create_session(); + }; + + $self->set_session($session); + + my @cookievals = split ',', $config->get_cookievals(); + my @ignore = $self->_store_cookie_vals( \@cookievals ); + $self->_restore_cookie_vals( \@cookievals, \@ignore ); + $config->defaults(); + + my ( $sessionid, $host ) = ( $session->id(), $config->get_host() ); + print "Set-Cookie: session=$sessionid; domain=$host; path=/\n"; + + return undef; +} + +sub _create_session($) { + my Xerl::Plugins::Session $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + + return CGI::Session->new( 'driver:File', undef ); +} + +sub _get_session($$) { + my Xerl::Plugins::Session $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + my $cookie = $_[1]; + + CGI::Session->name($cookie); + return CGI::Session->new( 'driver:File', $cookie ); +} + +sub _store_cookie_vals($$) { + my Xerl::Plugins::Session $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + my CGI::Session $session = $self->get_session(); + my $cookievals = $_[1]; + + my @set; + + for my $key (@$cookievals) { + if ( $config->exists($key) ) { + my $val = $config->getval($key); + $session->param( $key => $val ); + push @set, $key; + + } + elsif ( $config->exists("not$key") ) { + $session->clear($key); + push @set, "not$key"; + } + } + + return grep !/\.feed/, @set; +} + +sub _restore_cookie_vals($$$) { + my Xerl::Plugins::Session $self = $_[0]; + my Xerl::Page::Configure $config = $self->get_config(); + my CGI::Session $session = $self->get_session(); + my ( $cookievals, $ignore ) = @_[ 1 .. 2 ]; + + KEY: for my $key (@$cookievals) { + for my $ig (@$ignore) { + next KEY if $key eq $ig; + } + + if ( defined( my $val = $session->param($key) ) ) { + $val =~ s#/\.\.##g; + $config->setval( $key => $val ) if $val; + } + } + + return undef; +} + +1; + diff --git a/Xerl/Tools/FileIO.pm b/Xerl/Tools/FileIO.pm new file mode 100644 index 0000000..6117bd0 --- /dev/null +++ b/Xerl/Tools/FileIO.pm @@ -0,0 +1,186 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::Tools::FileIO; + +use strict; +use warnings; + +use Xerl::Base; +use Xerl::Main::Global; + +sub dslurp($;$) { + my Xerl::Tools::FileIO $self = $_[0]; + + my $path = $self->get_path(); + + $path .= '/' unless $path =~ /\/$/; + opendir my $dir, $path or Xerl::Main::Global::ERROR( $!, $path, caller() ); + + my @dir = sort + map { $path . $_ } + grep { /^[^\.]/o } readdir($dir); + + @dir = map { s#.*/([^/]+\..+)$#$1#o; $_ } @dir + if $self->basename_exists(); + + closedir $dir; + $self->set_array( \@dir ); + + return undef; +} + +sub fslurp($) { + my Xerl::Tools::FileIO $self = $_[0]; + my $path = SECUREPATH( $self->get_path() ); + + Xerl::Main::Global::HTTP( 404, "Not found: $path" ) + unless -f $path; + + open my $file, $path or Xerl::Main::Global::ERROR( $!, $path, caller() ); + flock $file, 2; + + my @slurp = <$file>; + + flock $file, 3; + close $file; + + $self->set_array( \@slurp ); + + return undef; +} + +sub exists($) { + my Xerl::Tools::FileIO $self = $_[0]; + my $path = SECUREPATH( $self->get_path() ); + + return -e $path; +} + +sub fwrite($) { + my Xerl::Tools::FileIO $self = $_[0]; + $self->_fwrite(0); + + return undef; +} + +sub fwriteappend($) { + my Xerl::Tools::FileIO $self = $_[0]; + + $self->_fwrite(1); + + return undef; +} + +sub _fwrite($;$) { + my Xerl::Tools::FileIO $self = $_[0]; + my $append = $_[1]; + + my ( $path, $filename ) = + ( SECUREPATH( $self->get_path() ), SECUREPATH( $self->get_filename() ) ); + + my $path_ = ''; + for ( split /\//, $path ) { + $path_ .= $_ . '/'; + mkdir $path_ + or Xerl::Main::Global::ERROR( $!, $path_, caller() ) + unless -d $path_; + } + + my $f; + if ( $append == 0 ) { + open $f, ">$path$filename" + or Xerl::Main::Global::ERROR( $!, $path . $filename, caller() ); + + } + else { + open $f, ">>$path$filename" + or Xerl::Main::Global::ERROR( $!, $path . $filename, caller() ); + } + + flock $f, 2; + print $f @{ $self->get_array() }; + flock $f, 3; + close $f; + + return undef; +} + +sub print($) { + my Xerl::Tools::FileIO $self = $_[0]; + + print @{ $self->get_array() }; + + return undef; +} + +sub reverse_array($) { + my Xerl::Tools::FileIO $self = $_[0]; + + my @array = reverse @{ $self->get_array() }; + $self->set_array( \@array ); + + return undef; +} + +sub merge($$) { + my Xerl::Tools::FileIO( $self, $other ) = @_; + + my @merged = ( @{ $self->get_array() }, @{ $other->get_array() } ); + my Xerl::Tools::FileIO $fio = Xerl::Tools::FileIO->new(); + + $fio->set_array( \@merged ); + return $fio; +} + +sub shift($) { + my Xerl::Tools::FileIO $self = $_[0]; + chomp( my $shift = shift @{ $self->get_array() } ); + + return $shift; +} + +sub pop($) { + my Xerl::Tools::FileIO $self = $_[0]; + chomp( my $pop = pop @{ $self->get_array() } ); + + return $pop; +} + +use overload '+' => \&merge; + +sub SECUREPATH($) { + my $path = $_[0]; + + $path =~ s/\.\.+\/?//g; + + return $path; +} + +1; diff --git a/Xerl/XML/Element.pm b/Xerl/XML/Element.pm new file mode 100644 index 0000000..a094ee6 --- /dev/null +++ b/Xerl/XML/Element.pm @@ -0,0 +1,111 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::XML::Element; + +use strict; +use warnings; + +use Xerl::Base; + +sub starttag($$) { + my Xerl::XML::Element $self = $_[0]; + my ( $name, $temp ) = ( $_[1], undef ); + + return $self if $self->get_name() eq $name; + return undef if ref $self->get_array() ne 'ARRAY'; + + for ( @{ $self->get_array() } ) { + $temp = $_->starttag($name); + return $temp if defined $temp; + } + + return undef; +} + +sub starttag2($$$) { + my Xerl::XML::Element $self = $_[0]; + my ( $name, $after ) = @_[ 1 ... 2 ]; + + my Xerl::XML::Element $element = $self->starttag($name); + return $element->starttag($after) if defined $element; + + return undef; +} + +sub params_str($) { + my Xerl::XML::Element $self = $_[0]; + my $params = $self->get_params(); + + return if $params eq ''; + + return join '', map { " $_=\"" . $params->{$_} . '"' } keys %$params; +} + +# Only for testing +sub print($) { + my Xerl::XML::Element $self = $_[0]; + print $self. "::print(\$)\n"; + + my $sub; + $sub = sub { + my ( $element, $spaceing ) = @_; + my $spaces = ' ' x $spaceing; + + print $spaces, '<', $element->get_name(), ">\n"; + print "$spaces [$_=", _no_newline( $$element{$_} ), "]\n" + for keys %$element; + + #if ($element->exists('params')) { + if ( $element->params_exists() ) { + print "$spaces Params:\n"; + while ( my ( $key, $val ) = each %{ $element->get_params() } ) { + print "$spaces $key=$val\n"; + } + } + + return unless ref $element->get_array() eq 'ARRAY'; + $sub->( $_, $spaceing + 1 ) for @{ $element->get_array() }; + }; + + $sub->( $self, 0 ); + print $self. "::print(\$)::END\n"; + + return undef; +} + +sub _no_newline($) { + my $line = $_[0]; + + $line =~ s/\n//g; + + return $line; +} + +1; diff --git a/Xerl/XML/Reader.pm b/Xerl/XML/Reader.pm new file mode 100644 index 0000000..1a9288b --- /dev/null +++ b/Xerl/XML/Reader.pm @@ -0,0 +1,195 @@ +# Xerl (c) 2005-2009, Dipl.-Inform. (FH) Paul C. Buetow +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.buetow.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED Paul C. Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT Paul C. Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +package Xerl::XML::Reader; + +use strict; +use warnings; + +use Xerl::Base; +use Xerl::XML::Element; + +sub open($) { + my Xerl::XML::Reader $self = $_[0]; + + my Xerl::Tools::FileIO $xmlfile = + Xerl::Tools::FileIO->new( path => $self->get_path() ); + + $xmlfile->fslurp(); + + # Xerl::Main::Global::PLAIN($self->get_path()); + # Xerl::Main::Global::DEBUG(@{$xmlfile->get_array()}); + + $self->set_array( $xmlfile->get_array() ); + + return undef; +} + +sub parse($) { + my Xerl::XML::Reader $self = $_[0]; + + my $rarray = $self->get_array(); + return $self unless ref $rarray eq 'ARRAY'; + + my Xerl::XML::Element $element = Xerl::XML::Element->new(); + my Xerl::XML::Element( $root, $next, $prev, $insert ); + + # Prove and remove XML Header. + Xerl::Main::Global::ERROR( 'No valid XML header', caller() ) + unless $rarray->[0] =~ s/<\?xml .*?version.+?\?>//io; + + my ( $newlineadd, $linecount, $notrim ) = ( 0, 0, 0 ); + + #for my $line (@$rarray) { + for my $line (@$rarray) { + $newlineadd = 1 if length $line == 1 and $linecount > 3; + ++$linecount; + + $line =~ s/\\/!!GT!!/g; + + # Allow + my $is_single_tag = $line =~ s#<([^/].+?)( (.*?))? ?/ *>#<$1 $3>#o; + + # Open XML tag + if ( $line =~ s#<([^/].+?)( (.*?))? *>##o ) { + my ( $name, $params ) = ( $1, $3 ); + + # Ignore XML comments + next if $name =~ /^!--/o; + + $next = Xerl::XML::Element->new(); + $next->set_name($name); + $next->set_prev($element); + $next->set_single($is_single_tag); + + # Handle tag parameters + if ( defined $params ) { + my %params = $params =~ / + (?: ( [^\s]+? ) \s*=\s* ( + (?: '(?:.|(?:\\'))*?' ) | + (?: "(?:.|(?:\\"))*?" ) | + (?: [^\s]+ ) ) ) + /gox; + + # Remove " and ' + $params{$_} =~ s/^(?:"|')|(?:"|')$//go for keys %params; + $next->set_params( \%params ); + $notrim = 1 if exists $params{notrim}; + } + + $element->push_array($next); + + $root = $element unless defined $root; + $element = $next; + $insert = $element; + + redo; + } + + # Close XML tag + if ( $line =~ s#<(/.+?)>##o ) { + + #print "XML::<$1>\n"; + if ( $element->get_name() eq 'includefiles' ) { + my $config = $self->get_config(); + my $params = $element->get_params(); + my $path = + $config->get_hostpath() . 'content/' . $params->{reldir}; + my $pattern = $params->{pattern}; + my $maxitems = + exists $params->{maxitems} ? $params->{maxitems} : 100; + my $startindex = + exists $params->{startindex} ? $params->{startindex} : 0; + + my Xerl::Tools::FileIO $io = + Xerl::Tools::FileIO->new( path => $path ); + + $io->dslurp(); + $io->reverse_array() if exists $params->{reversed}; + + for my $include ( grep { /$pattern/o } @{ $io->get_array() } ) { + last unless $maxitems--; + next if 0 < $startindex--; + + my Xerl::XML::Reader $reader = Xerl::XML::Reader->new( + path => $include, + config => $config + ); + + $reader->open(); + $reader->parse(); + + my Xerl::XML::Element $starttag = + $reader->get_root()->starttag('content'); + + my $sep = + exists $params->{separator} + ? $params->{separator} + : 'noop'; + $starttag->set_name($sep); + $element->set_name('noop'); + $element->push_array($starttag); + } + } + + $insert = $element; + $prev = $element->get_prev(); + $element = $prev if defined $prev; + $notrim = 0 if $notrim; + + redo; + } + + # XML text + if ( defined $insert + and $line =~ s/^( *)(.+?) *$/$notrim ? $1.$2 : $2/oe ) + { + + if ($newlineadd) { + $insert->append_text("\n"); + $newlineadd = 0; + } + + $line =~ s/!!LT!!//g; + + $insert->append_text($line); + } + } + + $root->set_name('root'); + + # $root->print(); + $self->set_root($root); + + return undef; +} + +1; diff --git a/config.txt b/config.txt new file mode 100644 index 0000000..ea9b07b --- /dev/null +++ b/config.txt @@ -0,0 +1,24 @@ +# TODO: Allow comments behind the options! +# defaultproto will be used if not ENV(HTTPS)==on +#nocache=defined +#nocache=1 +cacheroot=/var/www/xerlcache/ +cookievals=nocache,plain,devel,style,template +ctype.asc=text/plain +ctype.css=text/css +ctype.jpg=image/jpg +ctype.pdf=application/pdf +ctype.png=image/png +ctype.txt=text/plain +ctype.xml=text/plain +defaultcontent=home +defaulthost=default +defaultoutputformat=xhtml +defaultproto=http +defaultstyle=default.css +defaulttemplate=xhtml +dslvpnrouter.buetow.org=vpndslrouter.buetow.org +hidesubhome=1 +hostroot=/var/www/svn/xerlhosts/branches/stable/hosts/ +statsroot=/var/www/xerlstats/ +404=http://www.buetow.org diff --git a/index.pl b/index.pl new file mode 100755 index 0000000..8afda26 --- /dev/null +++ b/index.pl @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Xerl; + +my Xerl $xerl = Xerl->new( config => 'config.txt' ); +$xerl->run(); + diff --git a/scripts/modules/file.pm b/scripts/modules/file.pm new file mode 100644 index 0000000..4326026 --- /dev/null +++ b/scripts/modules/file.pm @@ -0,0 +1,54 @@ +# Xerl Copyright (c) 2005 2006 2007 2008, Paul Buetow (http://www.pblabs.net) +# +# E-Mail: xerl@dev.buetow.org WWW: http://xerl.perl9.org +# +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are met: +# * Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# * Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# * Neither the name of P. B. Labs nor the names of its contributors may +# be used to endorse or promote products derived from this software +# without specific prior written permission. +# +# THIS SOFTWARE IS PROVIDED BY Paul Buetow ``AS IS'' AND ANY EXPRESS OR +# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +# WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +# DISCLAIMED. IN NO EVENT SHALL Paul Buetow BE LIABLE FOR ANY DIRECT, +# INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +# (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +# STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING +# IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +# POSSIBILITY OF SUCH DAMAGE. + +sub dopen { + my $shift = shift; + opendir DIR, $shift or die "$shift: $!\n"; + my @dir = readdir(DIR); + closedir DIR; + return @dir; +} + +sub fopen { + my $shift = shift; + open FILE, $shift or die "$shift: $!\n"; + my @file = ; + close FILE; + return @file; +} + +sub fwrite { + my $shift = shift; + my @file = @_; + open FILE, ">$shift" or die "$shift: $!\n"; + print FILE @file; + close FILE; +} + +1; diff --git a/scripts/mreplace.sh b/scripts/mreplace.sh new file mode 100755 index 0000000..1ef5cc4 --- /dev/null +++ b/scripts/mreplace.sh @@ -0,0 +1,12 @@ +#!/bin/sh + +for j in pm pl xml txt css +do + for i in `find . -name "*.$j"` + do + echo $i + sed "s/$1/$2/g" $i > temp + mv -f temp $i + done +done + diff --git a/scripts/replace.sh b/scripts/replace.sh new file mode 100755 index 0000000..c6f9d4c --- /dev/null +++ b/scripts/replace.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +sed "s/$2/$3/g" $1 > temp +mv -f temp $1 + + diff --git a/scripts/stats.pl b/scripts/stats.pl new file mode 100644 index 0000000..425261f --- /dev/null +++ b/scripts/stats.pl @@ -0,0 +1,92 @@ +#!/usr/bin/perl + +# The yChat Project (2003, 2004) +# The Xerl Project (2005, 2006) +# +# This script generates source code and project statistics + +use strict; + +use scripts::modules::file; + +my %stats; +my $param = shift; + +recursive('.'); + +$stats{"Lines total"} = + $stats{"Lines of source"} + + $stats{"Lines of scripts"} + + $stats{"Lines of text"} + + $stats{"Lines of CSS"} + + $stats{"Lines of XML"}; + +unless ( defined $param ) { + print "$_ = " . $stats{$_} . "\n" for sort keys %stats; + +} +else { + print $stats{$_} . ' ' for sort keys %stats; +} + +print "\n"; + +sub recursive { + my $shift = shift; + return unless -d $shift; + my @dir = dopen($shift); + + foreach (@dir) { + next if /^\.$/o or /^\.{2}$/o; + + if ( -f "$shift/$_" ) { + ++$stats{"Number of files total"}; + filestats("$shift/$_"); + + } + elsif ( -d "$shift/$_" ) { + ++$stats{"Number of dirs total"}; + recursive("$shift/$_"); + } + } +} + +sub filestats { + my $shift = shift; + if ( $shift =~ /\.(cpp|h|tmpl)$/o ) { + ++$stats{"Number of source files"}; + $stats{"Lines of source"} += countlines($shift); + + } + elsif ( $shift =~ /\.css$/o ) { + ++$stats{"Number of CSS files"}; + $stats{"Lines of CSS"} += countlines($shift); + + } + elsif ( $shift =~ /\.(gif|png|jpg)$/o ) { + ++$stats{"Number of gfx files"}; + + } + elsif ( $shift =~ /(\.xml)$/o ) { + ++$stats{"Number of XML files"}; + $stats{"Lines of XML"} += countlines($shift); + + } + elsif ( $shift =~ /(\.pl|\.pm|\.sh|configure.*|Makefile.*)$/o ) { + ++$stats{"Number of script files"}; + $stats{"Lines of scripts"} += countlines($shift); + + } + elsif ( $shift =~ /(\.txt|[A-Z]+)$/o ) { + ++$stats{"Number of text files"}; + $stats{"Lines of text"} += countlines($shift); + + } + elsif ( $shift =~ /\.so$/o ) { + ++$stats{"Number of compiled module files"}; + } +} + +sub countlines { + return scalar fopen shift; +} diff --git a/scripts/stats/calc.sh b/scripts/stats/calc.sh new file mode 100755 index 0000000..dfb7453 --- /dev/null +++ b/scripts/stats/calc.sh @@ -0,0 +1,49 @@ +#!/bin/sh +# By Paul C. Buetow (http://www.buetow.org) + +perl=' + /.*? (.*?) (.*?) /o + && ++$ip{$2}{$1} && ++$p{$1} + && ++$h{$2} && ++$t + for <>; + $l = do { $_ = length $t; $_ < 4 ? 4 : $_ }; + printf " # %$l"."s%4s %$l"."s%4s %24s\n", + "HITS", "%", "UNIQ", "%", "SITE ADDRESS"; + printf "%2.d %$l.d%4.f %$l.d%4.f %24s\n", + ++$i, $h{$_}, 100*$h{$_}/$t, + ($n = keys %{$ip{$_}}), 100*$n/(keys %p),$_ + and $i==15 && last + for sort { $h{$b} <=> $h{$a} } keys %h' + +ls=`ls *.log` +cat << STATS | less +Weekly top 15: + +`echo "$ls" | tail -n 7 | xargs cat | perl -e "$perl"` + +Monthly top ten: + +`echo "$ls" | tail -n 28 | xargs cat | perl -e "$perl"` + +Yearly top ten: + +`echo "$ls" | tail -n 356 | xargs cat | perl -e "$perl"` + +STATS +ftp://ftp.buetow.org download top ten: + +exit 0 +`gawk ' + $9 ~ /^\/data\/ftp\// { ++dl[\$9] } + END { + for (k in dl) + d[k] = sprintf("%3d %s", dl[k], k) + n = asort(d) + rank = 1 + for (i = n; i > 0 && rank < 11; --i) + printf "%2.d%s\n", rank++, d[i] + }' /var/log/proftpdtransfer.log | sed s,/data/ftp/,,` + +This stats are powered by Perl, GNU AWK and Bourne Shell +STATS + diff --git a/scripts/stats/clean.sh b/scripts/stats/clean.sh new file mode 100755 index 0000000..ba0f0e8 --- /dev/null +++ b/scripts/stats/clean.sh @@ -0,0 +1,49 @@ +#!/bin/sh + +# 2006 - 2008 The Xerl Project + +for log in *.log +do + re='' + for remove in \ + Charlotte \ + Exabot \ + Mnogo \ + Netcraft \ + Perl \ + Python \ + SurveyBot \ + VoilaBot \ + Yandex \ + Yeti \ + ajSitemap \ + archiver \ + crawler \ + feed \ + findlinks \ + fulltext \ + googlebot \ + grabber \ + jeeves \ + msnbot \ + pear \ + pingdom \ + rss2 \ + sagool \ + sbider \ + slurp \ + spider \ + tagsdir \ + validator \ + walhello \ + ;do + if [ -z "$re" ] + then + re="($remove)" + else + re="$re|($remove)" + fi + done + grep -E -i -v "$re" $log > $log.new + mv -f $log.new $log +done diff --git a/scripts/stats/replace.sh b/scripts/stats/replace.sh new file mode 100755 index 0000000..1624364 --- /dev/null +++ b/scripts/stats/replace.sh @@ -0,0 +1,11 @@ +#!/bin/sh + +from="vs.buetow.org" +to="vs-sim.buetow.org" + +for log in *.log +do + sed "s/$from/$to/" $log > $log.new + mv -f $log.new $log +done + diff --git a/scripts/stats/stats.sh b/scripts/stats/stats.sh new file mode 100755 index 0000000..0f1c070 --- /dev/null +++ b/scripts/stats/stats.sh @@ -0,0 +1,61 @@ +#!/bin/sh + +# 2007 (C) Paul C. Buetow (http://paul.buetow.org) + +if [ "$1" != "xerl" ] +then + perl=' + /.*? (.*?) (.*?) /o + && ++$ip{$2}{$1} && ++$p{$1} + && ++$h{$2} && ++$t + for <>; + $l = do { $_ = length $t; $_ < 4 ? 4 : $_ }; + printf " # %$l"."s%4s %$l"."s%4s %24s\n", + "HITS", "%", "UNIQ", "%", "SITE ADDRESS"; + printf "%2.d %$l.d%4.f %$l.d%4.f %24s\n", + ++$i, $h{$_}, 100*$h{$_}/$t, + ($n = keys %{$ip{$_}}), 100*$n/(keys %p),$_ + and $i==20 && last + for sort { $h{$b} <=> $h{$a} } keys %h' +else + perl=' + /.*? (.*?) (.*?) /o + && ++$ip{$2}{$1} && ++$p{$1} + && ++$h{$2} && ++$t + for <>; + $l = do { $_ = length $t; $_ < 4 ? 4 : $_ }; + printf "%02.d %0$l.d %02.f %0$l.d %02.f %24s\n", + ++$i, $h{$_}, 100*$h{$_}/$t, + ($n = keys %{$ip{$_}}), 100*$n/(keys %p), "!!URL(http://$_)!!" + and $i==20 && last + for sort { $h{$b} <=> $h{$a} } keys %h' +fi + +#./clean.sh + +ls=`ls $path*.log` + +cat << STATS +No IP addresses are being logged by Xerl! + + +Yesterdays top list (pos, total hits, total %, unique hits, unique %): + +`echo "$ls" | tail -n 2 | head -n 1 | xargs cat | perl -e "$perl"` + +Last 7 days top list (pos, total hits, total %, unique hits, unique %): + +`echo "$ls" | tail -n 8 | head -n 7 | xargs cat | perl -e "$perl"` + +Last 30 days top list (pos, total hits, total %, unique hits, unique %): + +`echo "$ls" | tail -n 31 | head -n 30 | xargs cat | perl -e "$perl"` + +Last 365 days top list (pos, total hits, total %, unique hits, unique %): + +`echo "$ls" | tail -n 366 | head -n 365 | xargs cat | perl -e "$perl"` + +Overall top list (pos, total hits, total %, unique hits, unique %): + +`echo "$ls" | xargs cat | perl -e "$perl"` +STATS -- cgit v1.2.3