From: Leandro Lucarella Date: Wed, 28 Jan 2004 17:31:06 +0000 (+0000) Subject: Se agregan archivos complementarios para que ande el embperl. X-Git-Tag: svn_import~20 X-Git-Url: https://git.llucax.com/mecon/scripts.git/commitdiff_plain/3006a93e549418d56106029ff6a9844c99f3b71e?ds=sidebyside Se agregan archivos complementarios para que ande el embperl. --- diff --git a/embperl/DumperISO.pm b/embperl/DumperISO.pm new file mode 100644 index 0000000..4e92365 --- /dev/null +++ b/embperl/DumperISO.pm @@ -0,0 +1,332 @@ +# +# Copyright (c) 1998 Jonathan Eisenzopf +# 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( + "" . + &Tree2XML($ref, 1) . + "\n\n" + ); +} + +sub Tree2XML { + my ($ref, $indent) = @_; + my $string = ''; + + # SCALAR REFERENCE + if (defined(ref($ref)) && (ref($ref) eq 'SCALAR')) { + $string .= "\n" . " " x $indent . "" . &QuoteXMLChars($$ref) . ""; + } + + # HASH REFERENCE + elsif (defined(ref($ref)) && (ref($ref) eq 'HASH')) { + $string .= "\n" . " " x $indent . ""; + $indent++; + foreach my $key (keys(%$ref)) { + $string .= "\n" . " " x $indent . ""; + if (ref($ref->{$key})) { + $string .= &Tree2XML($ref->{$key}, $indent+1); + $string .= "\n" . " " x $indent . ""; + } else { + $string .= &QuoteXMLChars($ref->{$key}) . ""; + } + } + $indent--; + $string .= "\n" . " " x $indent . ""; + } + + # ARRAY REFERENCE + elsif (defined(ref($ref)) && (ref($ref) eq 'ARRAY')) { + $string .= "\n" . " " x $indent . ""; + $indent++; + for (my $i=0; $i < @$ref; $i++) { + $string .= "\n" . " " x $indent . ""; + if (ref($ref->[$i])) { + $string .= &Tree2XML($ref->[$i], $indent+1); + $string .= "\n" . " " x $indent . ""; + } else { + $string .= &QuoteXMLChars($ref->[$i]) . ""; + } + } + $indent--; + $string .= "\n" . " " x $indent . ""; + } + + ## SCALAR + else { + $string .= "\n" . " " x $indent . "" . &QuoteXMLChars($ref) . ""; + } + + return($string); +} + +sub QuoteXMLChars { + $_[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', + + foo + +END_TEST1 + + <<'END_TEST2', + + Hi Mom + +END_TEST2 + + <<'END_TEST3', + + + value1 + value2 + + +END_TEST3 + + <<'END_TEST4', + + + foo + bar + + +END_TEST4 + + <<'END_TEST5', + + + Scalar + + ScalarRef + + + + foo + bar + + + + + value1 + value2 + + + + +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 = < + foo + +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 + +=head1 CREDITS + +Chris Thorman +L.M.Orchard +DeWitt Clinton + +=head1 SEE ALSO + +perl(1), XML::Parser(3). + +=cut diff --git a/embperl/Php2Embperl_Session.epl b/embperl/Php2Embperl_Session.epl new file mode 100644 index 0000000..560c63a --- /dev/null +++ b/embperl/Php2Embperl_Session.epl @@ -0,0 +1,170 @@ +[# +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 ('',); + +$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; diff --git a/embperl/README b/embperl/README new file mode 100644 index 0000000..709d56e --- /dev/null +++ b/embperl/README @@ -0,0 +1,14 @@ +$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. + diff --git a/embperl/SimpleXMLISO.pm b/embperl/SimpleXMLISO.pm new file mode 100644 index 0000000..4d67f81 --- /dev/null +++ b/embperl/SimpleXMLISO.pm @@ -0,0 +1,80 @@ +############################################################################# +# +# 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 "" ) { + $eval .= "{"; + $isarray[++$nivel] = 0; + } + if ( lc( $line ) eq "" ) { + $eval .= "["; + $isarray[++$nivel] = 1; + } + if ( lc( $line ) eq "" ) { + $nivel--; + $eval .= "},"; + } + if ( lc( $line ) eq "" ) { + $nivel--; + $eval .= "],"; + } + if ( $line =~ /([^<>]*)(<\/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; + 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'} ); +} + + diff --git a/embperl/libapache-tempfile-perl_0.04-1_all.deb b/embperl/libapache-tempfile-perl_0.04-1_all.deb new file mode 100644 index 0000000..88b725d Binary files /dev/null and b/embperl/libapache-tempfile-perl_0.04-1_all.deb differ