--- /dev/null
+#
+# Copyright (c) 1998 Jonathan Eisenzopf <eisen@pobox.com>
+# XML::DumperISO is free software. You can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package XML::DumperISO;
+
+BEGIN {
+ use strict;
+ use vars qw($VAR1 $VERSION);
+ use Data::Dumper;
+ $VERSION = '0.4';
+}
+
+sub new {
+ my $class = shift;
+ my $self = {};
+ return bless $self,$class;
+}
+
+sub pl2xml {
+ my ($obj,$ref) = @_;
+ return $obj->pl2xml_string($ref);
+}
+
+sub pl2xml_string {
+ my ($obj,$ref) = @_;
+ return(
+ "<perldata>" .
+ &Tree2XML($ref, 1) .
+ "\n</perldata>\n"
+ );
+}
+
+sub Tree2XML {
+ my ($ref, $indent) = @_;
+ my $string = '';
+
+ # SCALAR REFERENCE
+ if (defined(ref($ref)) && (ref($ref) eq 'SCALAR')) {
+ $string .= "\n" . " " x $indent . "<scalarref>" . &QuoteXMLChars($$ref) . "</scalarref>";
+ }
+
+ # HASH REFERENCE
+ elsif (defined(ref($ref)) && (ref($ref) eq 'HASH')) {
+ $string .= "\n" . " " x $indent . "<hash>";
+ $indent++;
+ foreach my $key (keys(%$ref)) {
+ $string .= "\n" . " " x $indent . "<item key=\"" . &QuoteXMLChars($key) . "\">";
+ if (ref($ref->{$key})) {
+ $string .= &Tree2XML($ref->{$key}, $indent+1);
+ $string .= "\n" . " " x $indent . "</item>";
+ } else {
+ $string .= &QuoteXMLChars($ref->{$key}) . "</item>";
+ }
+ }
+ $indent--;
+ $string .= "\n" . " " x $indent . "</hash>";
+ }
+
+ # ARRAY REFERENCE
+ elsif (defined(ref($ref)) && (ref($ref) eq 'ARRAY')) {
+ $string .= "\n" . " " x $indent . "<array>";
+ $indent++;
+ for (my $i=0; $i < @$ref; $i++) {
+ $string .= "\n" . " " x $indent . "<item key=\"$i\">";
+ if (ref($ref->[$i])) {
+ $string .= &Tree2XML($ref->[$i], $indent+1);
+ $string .= "\n" . " " x $indent . "</item>";
+ } else {
+ $string .= &QuoteXMLChars($ref->[$i]) . "</item>";
+ }
+ }
+ $indent--;
+ $string .= "\n" . " " x $indent . "</array>";
+ }
+
+ ## SCALAR
+ else {
+ $string .= "\n" . " " x $indent . "<scalar>" . &QuoteXMLChars($ref) . "</scalar>";
+ }
+
+ return($string);
+}
+
+sub QuoteXMLChars {
+ $_[0] =~ s/&/&/g;
+ $_[0] =~ s/</</g;
+ $_[0] =~ s/>/>/g;
+ $_[0] =~ s/'/'/g;
+ $_[0] =~ s/"/"/g;
+ return($_[0]);
+}
+
+sub xml2pl {
+ my ($obj,$tree) = @_;
+
+ ## Skip enclosing "perldata" level
+ my $TopItem = $tree->[1];
+ my $ref = &Undump($TopItem);
+
+ return($ref);
+}
+
+## Undump
+## Takes a parse tree of the XML generated by pl2xml, and recursively
+## undumps it to create a data structure in memory. The top-level
+## object is a scalar, a reference to a scalar, a hash, or an array.
+## Hashes and arrays may themselves contain scalars, or references to
+## scalars, or references to hashes or arrays, with the exception that
+## scalar values are never "undef" because there's currently no way to
+## represent undef in the dumped data.
+
+sub Undump {
+ my ($Tree) = shift;
+ my $ref = undef;
+ my $FoundScalar;
+ my $i;
+
+ for ($i = 1; $i < $#$Tree; $i+=2) {
+ if (lc($Tree->[$i]) eq 'scalar') {
+ ## Make a copy of the string
+ $ref = $Tree->[$i+1]->[2];
+ last;
+ }
+ if (lc($Tree->[$i]) eq 'scalarref') {
+ ## Make a ref to a copy of the string
+ $ref = \ "$Tree->[$i+1]->[2]";
+ last;
+ } elsif (lc($Tree->[$i]) eq 'hash') {
+ $ref = {};
+ my $j;
+ for ($j = 1; $j < $#{$Tree->[$i+1]}; $j+=2) {
+ next unless $Tree->[$i+1]->[$j] eq 'item';
+ my $ItemTree = $Tree->[$i+1]->[$j+1];
+ next unless defined(my $key = $ItemTree->[0]->{key});
+ $ref->{$key} = &Undump($ItemTree);
+ }
+ last;
+ } elsif (lc($Tree->[$i]) eq 'array') {
+ $ref = [];
+ my $j;
+ for ($j = 1; $j < $#{$Tree->[$i+1]}; $j+=2) {
+ next unless $Tree->[$i+1]->[$j] eq 'item';
+ my $ItemTree = $Tree->[$i+1]->[$j+1];
+ next unless defined(my $key = $ItemTree->[0]->{key});
+ $ref->[$key] = &Undump($ItemTree);
+ }
+ last;
+ } elsif (lc($Tree->[$i]) eq '0') {
+ $FoundScalar = $Tree->[$i + 1] unless defined $FoundScalar;
+ } else {
+ ## Unrecognized tag. Just move on.
+ }
+ }
+
+ ## If $ref is not set at this point, it means we've just
+ ## encountered a scalar value directly inside the item tag.
+
+ $ref = $FoundScalar unless defined($ref);
+
+ done:
+ return ($ref);
+}
+
+### TestRoundTrip
+### Tests the conversion of perl data structures into XML and back again
+###
+### Invoke with:
+###
+### perl -e 'use XML::DumperISO; &XML::DumperISO::TestRoundTrip();'
+###
+### The 5 sets of sample data below show some typical cases:
+
+sub TestRoundTrip
+{
+ my $TestRuns =
+ [
+
+ <<'END_TEST1',
+<perldata>
+ <scalar>foo</scalar>
+</perldata>
+END_TEST1
+
+ <<'END_TEST2',
+<perldata>
+ <scalarref>Hi Mom</scalarref>
+</perldata>
+END_TEST2
+
+ <<'END_TEST3',
+<perldata>
+ <hash>
+ <item key="key1">value1</item>
+ <item key="key2">value2</item>
+ </hash>
+</perldata>
+END_TEST3
+
+ <<'END_TEST4',
+<perldata>
+ <array>
+ <item key="0">foo</item>
+ <item key="1">bar</item>
+ </array>
+</perldata>
+END_TEST4
+
+ <<'END_TEST5',
+<perldata>
+ <array>
+ <item key="0">Scalar</item>
+ <item key="1">
+ <scalarref>ScalarRef</scalarref>
+ </item>
+ <item key="2">
+ <array>
+ <item key="0">foo</item>
+ <item key="1">bar</item>
+ </array>
+ </item>
+ <item key="3">
+ <hash>
+ <item key="key1">value1</item>
+ <item key="key2">value2</item>
+ </hash>
+ </item>
+ </array>
+</perldata>
+END_TEST5
+
+ ];
+
+ my $TestNum;
+ my $TestData;
+ foreach $TestData (@$TestRuns)
+ {
+ $TestNum++;
+
+ use XML::Parser;
+ my $Parser = XML::Parser->new(Style => 'Tree');
+ my $Tree = $Parser->parse($TestData);
+
+ my $DumperISO = new XML::DumperISO();
+ my $Ref = $DumperISO->xml2pl($Tree);
+
+ my $ReDump = $DumperISO->pl2xml_string($Ref);
+
+ if ($TestData eq $ReDump)
+ {
+ print STDERR ("Test $TestNum: Success.\n\n" .
+ "Perl tree:\n" .
+ &Data::Dumper::Dumper($Ref) .
+ "\n\n");
+ }
+ else
+ {
+ print STDERR ("TestRoundTrip: data doesn't match!\n\n" .
+ "Orig:\n$TestData\nRound Trip:\n$ReDump\n");
+ }
+ }
+}
+
+
+
+1;
+__END__
+
+=head1 NAME
+
+XML::DumperISO - Perl module for dumping Perl objects from/to XML
+
+=head1 SYNOPSIS
+
+ # Convert Perl code to XML
+ use XML::DumperISO;
+ my $dump = new XML::DumperISO;
+ $data = [
+ {
+ first => 'Jonathan',
+ last => 'Eisenzopf',
+ email => 'eisen@pobox.com'
+ },
+ {
+ first => 'Larry',
+ last => 'Wall',
+ email => 'larry@wall.org'
+ }
+ ];
+ $xml = $dump->pl2xml($perl);
+
+
+ # Convert XML to Perl code
+ use XML::DumperISO;
+ my $dump = new XML::DumperISO;
+
+ # some XML
+ my $xml = <<XML;
+<perldata>
+ <scalar>foo</scalar>
+</perldata>
+XML
+
+ # load Perl data structure from dumped XML
+ $data = $dump->xml2pl($Tree);
+
+=head1 DESCRIPTION
+
+XML::DumperISO dumps Perl data to a structured XML format.
+XML::DumperISO can also read XML data that was previously dumped
+by the module and convert it back to Perl.
+
+This is done via the following 2 methods:
+XML::DumperISO::pl2xml
+XML::DumperISO::xml2pl
+
+=head1 AUTHOR
+
+Jonathan Eisenzopf <eisen@pobox.com>
+
+=head1 CREDITS
+
+Chris Thorman <ct@ignitiondesign.com>
+L.M.Orchard <deus_x@pobox.com>
+DeWitt Clinton <dewitt@eziba.com>
+
+=head1 SEE ALSO
+
+perl(1), XML::Parser(3).
+
+=cut
--- /dev/null
+[#
+IMPORTANTE: ES NECESARIO QUE ESTE SCRIPT SE PONGA EN LA BARRA DE LA INTRANET NO
+EN SISTEMAS/INTRANET PORQUE LA COOKIE FUNCIONA A PARTIR DEL DIRECTORIO EN EL
+CUAL ESTE ESTE SCRIPT.
+#]
+[-
+use CGI qw/:standard/;
+use CGI::Cookie;
+
+
+if (!defined($fdat{'redirect'})) {
+ $http_headers_out {Location} = 'http://bal747f.mecon.ar/sistemas/intranet';
+ exit;
+}
+
+
+%cookies = fetch CGI::Cookie;
+$archivo = '/tmp/sess_'.$cookies{'PHPSESSID747F'}{'value'}[0];
+
+open (FILE, $archivo);
+$linea = join ('',<FILE>);
+
+$res = parseSession (linea => $linea);
+
+$udat{'user'} = $res->{'user'};
+$udat{'domain'} = $res->{'domain'};
+$udat{'nick'} = $res->{'nick'};
+$udat{'nro_doc'} = $res->{'nro_doc'};
+
+$http_headers_out {Location} = 'http://bal747f.mecon.ar/'.$fdat{'redirect'};
+
+exit;
+
+################# FIN SCRIPT
+
+sub parseSession
+{
+ my %params = @_;
+ my $op_value = $params{linea};
+ my $pos = 0;
+ my $name;
+ my $type;
+ my $type2;
+ my $len;
+ my $result;
+
+
+
+ while ($pos < 2){
+
+ #Obtengo el nombre del parametro
+ $name = substr($op_value, 0, index($op_value, '|'));
+ $op_value = substr($op_value, index($op_value, '|') + 1); #Depuro la linea
+ #Obtengo el tipo
+ $type = substr($op_value, 0, index($op_value, ':'));
+ $type2 = substr($op_value, 0, index($op_value, ';'));
+
+ #Caso particular
+ if ($type2 eq 'N') {
+ $type = 'N';
+ $op_value = substr($op_value, index($op_value, ';') + 1); #Depuro la linea
+ }
+ else {
+ $op_value = substr($op_value, index($op_value, ':') + 1); #Depuro la linea
+ }
+
+ if ($type eq 's') {
+ #Obtengo la longitud
+ $len = substr($op_value, 0, index($op_value, ':'));
+ #Obtengo el resto de la linea
+ $op_value = substr($op_value, index($op_value, ':') + 1);
+ if ($name eq 'usuario') {
+ $result->{'user'} = substr($op_value, 1, $len);
+ ($result->{'nick'}, $result->{'domain'}) = split ('@', $result->{'user'});
+ $op_value = substr($op_value, $len + 3);
+ $pos++;
+ }
+ elsif ($name eq 'documento') {
+ $result->{'nro_doc'} = substr($op_value, 1, $len);
+ $pos++;
+ }
+ else {
+ $op_value = substr($op_value, $len + 3);
+ }
+ }
+ elsif ($type eq 'i') {
+ $op_value = substr($op_value, index($op_value,';') + 1);
+ }
+ elsif ($type eq 'd') {
+ $op_value = substr($op_value, index($op_value,';') + 1);
+ }
+ elsif ($type eq 'b') {
+ $op_value = substr($op_value, index($op_value,';') + 1);
+ }
+ elsif ($type eq 'a') {
+ $op_value = parseContenido (cont => $op_value);
+ }
+ elsif ($type eq 'O') {
+ $len = substr($op_value, 0, index($op_value,':'));
+ $op_value = substr($op_value, index($op_value,':') + 1);
+ $op_value = substr($op_value, $len + 3);
+ $op_value = parseContenido (cont => $op_value);
+ }
+
+ if (length($op_value) < 1) {
+ $pos = 3;
+ }
+ }
+ return $result;
+}
+
+#Devuelve la linea sin el contenido
+sub parseContenido {
+ my %params = @_;
+ my $op_value = $params{cont};
+ my $type;
+ my $type2;
+ my $len;
+ my $seguir = 1;
+
+ #Elimino todo hasta el { inclusive
+ $op_value = substr($op_value, index($op_value, ':') + 2);
+
+
+ while ($seguir) {
+ #Obtengo el tipo
+ $type = substr($op_value, 0, index($op_value, ':'));
+ $type2 = substr($op_value, 0, index($op_value, ';')); #Caso particular Null
+
+ #Caso particular Null
+ if ($type2 eq 'N') {
+ $type = 'N';
+ $op_value = substr($op_value, index($op_value, ';') + 1); #Depuro la linea
+ }
+ else {
+ $op_value = substr($op_value, index($op_value, ':') + 1); #Depuro la linea
+ }
+ if ($type eq 's') {
+ #Obtengo la longitud
+ $len = substr($op_value, 0, index($op_value, ':'));
+ #Obtengo el resto de la linea
+ $op_value = substr($op_value, index($op_value, ':') + 1);
+ $op_value = substr($op_value, $len + 3);
+ }
+ elsif ($type eq 'i') {
+ $op_value = substr($op_value, index($op_value,';') + 1);
+ }
+ elsif($type eq 'd') {
+ $op_value = substr($op_value, index($op_value,';') + 1);
+ }
+ elsif($type eq 'b') {
+ $op_value = substr($op_value, index($op_value,';') + 1);
+ }
+ elsif($type eq 'a') {
+ $op_value = parseContenido (cont => $op_value);
+ }
+ elsif($type eq 'O') {
+ $op_value = parseContenido (cont => $op_value);
+ }
+
+ if (substr($op_value,0,1) eq '}') {
+ $op_value = substr($op_value,1);
+ $seguir = 0;
+ }
+ }
+ return $op_value;
+}
+
+-]
+1;
--- /dev/null
+$Id$
+
+Archivos necesarios para que Intranet ande con embperl.
+
+Copiar los archivos a la ruta indicada:
+
+Archivo Ruta
+------------------------------------------------------------------------
+SimpleXMLISO.pm /usr/share/perl5/Apache/Session/Serialize/
+DumperISO.pm /usr/share/perl5/XML/
+Php2Embperl_Session.epl /var/www/htdocs/ (DocumentRoot del apache)
+
+Instalar paquete libapache-tempfile-perl_0.04-1_all.deb.
+
--- /dev/null
+#############################################################################
+#
+# Apache::Session::Serialize::SimpleXML
+# Serializes session objects using Storable and pack
+#
+############################################################################
+
+package Apache::Session::Serialize::SimpleXMLISO;
+
+use vars qw($VERSION);
+use XML::DumperISO;
+use strict;
+
+$VERSION = '0.1';
+
+#################################################
+# Parsea un archivo XML con la limitacion de #
+# que debe tener un tag por linea. #
+#################################################
+sub semiXMLParse {
+ my @xml = split( "\n", shift );
+ my @isarray;
+ my $nivel = 0;
+ my $data;
+ my $eval = '$data=';
+ foreach my $line ( @xml ) {
+ $line =~ s/\s*(<.*>)\s*/$1/msg;
+ if ( lc( $line ) eq "<hash>" ) {
+ $eval .= "{";
+ $isarray[++$nivel] = 0;
+ }
+ if ( lc( $line ) eq "<array>" ) {
+ $eval .= "[";
+ $isarray[++$nivel] = 1;
+ }
+ if ( lc( $line ) eq "</hash>" ) {
+ $nivel--;
+ $eval .= "},";
+ }
+ if ( lc( $line ) eq "</array>" ) {
+ $nivel--;
+ $eval .= "],";
+ }
+ if ( $line =~ /<item key="(.*)">([^<>]*)(<\/item>)?/i ) {
+ $eval .= "'" . UnQuoteXMLChars( $1 ) . "'=>"
+ if ( not $isarray[$nivel] );
+ $eval .= "'" . UnQuoteXMLChars( $2 ) . "',"
+ if ( $3 );
+ }
+ }
+ chop $eval;
+ $eval .= ";";
+ eval $eval;
+
+ return $data;
+
+ ######################################################################
+ sub UnQuoteXMLChars {
+ my $str = shift;
+ $str =~ s/&/&/g;
+ $str =~ s/</</g;
+ $str =~ s/>/>/g;
+ $str =~ s/'/\\'/g;
+ $str =~ s/"/"/g;
+ return $str;
+ }
+}
+
+sub serialize {
+ my $session = shift;
+ my $dump = new XML::DumperISO;
+ $session->{'serialized'} = $dump->pl2xml( $session->{'data'} );
+}
+
+sub unserialize {
+ my $session = shift;
+ $session->{'data'} = semiXMLParse( $session->{'serialized'} );
+}
+
+
projects / mecon / scripts.git / commitdiff