static char *virt_handler =
"#  \n"
"#  This file is part of the OpenLink Software Virtuoso Open-Source (VOS)\n"
"#  project.\n"
"#  \n"
"#  Copyright (C) 1998-2006 OpenLink Software\n"
"#  \n"
"#  This project is free software; you can redistribute it and/or modify it\n"
"#  under the terms of the GNU General Public License as published by the\n"
"#  Free Software Foundation; only version 2 of the License, dated June 1991.\n"
"#  \n"
"#  This program is distributed in the hope that it will be useful, but\n"
"#  WITHOUT ANY WARRANTY; without even the implied warranty of\n"
"#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU\n"
"#  General Public License for more details.\n"
"#  \n"
"#  You should have received a copy of the GNU General Public License along\n"
"#  with this program; if not, write to the Free Software Foundation, Inc.,\n"
"#  51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA\n"
"#  \n"
"#  \n"
"package VIRT::Embed::Persistent;\n"
"\n"
" my $stdout_ref;\n"
" my $stdin_ref;\n"
" my $stderr_ref;\n"
"#use strict;\n"
" our %Cache;\n"
" use Symbol qw(delete_package);\n"
"\n"
" # static\n"
" sub valid_package_name {\n"
"     my($string) = @_;\n"
"     $string =~ s/([^A-Za-z0-9\\/])/sprintf(\"_%2x\",unpack(\"C\",$1))/eg;\n"
"     # second pass only for words starting with a digit\n"
"     $string =~ s|/(\\d)|sprintf(\"/_%2x\",unpack(\"C\",$1))|eg;\n"
"\n"
"     # Dress it up as a real package name\n"
"     $string =~ s|/|::|g;\n"
"     return \"Embed\" . $string;\n"
" }\n"
"\n"
" sub set_env_vars {\n"
"   my $v_options = shift;\n"
"   $$stderr_ref->{'html_mode'} = 0;\n"
"\n"
"   if ($$v_options{'__VIRT_CGI'} == '1')\n"
"     {\n"
"       foreach my $key (keys %$v_options)\n"
"	 {\n"
"	   if ($key !~ /__VIRT.*/)\n"
"	     {\n"
"	       my $val = $$v_options{$key};\n"
"#	       print STDERR \"set_env_vars [$key]=[$val]\\n\";\n"
"	       $ENV{$key} = $val;\n"
"	     }\n"
"	 }\n"
"     }\n"
"   else\n"
"     {\n"
"        $$stdout_ref->{'html_mode'} = 0;\n"
"     }\n"
" }\n"
"\n"
" # static\n"
" sub eval_file {\n"
"     my($filename, $delete, $v_options, $v_params, $v_lines) = @_;\n"
"     #print STDERR \"filename=[$filename] delete=[$delete] v_options=\".$v_options.\" v_params=\".$v_params.\" v_lines=\".$v_lines.\"\\n\";\n"
"     my $package = valid_package_name($filename);\n"
"     my $mtime = -M $filename;\n"
"     $stdout_ref->text_reset;\n"
"     $stderr_ref->text_reset;\n"
"     $stdin_ref->setouttext ($v_params);\n"
"#    foreach my $xx2 ( keys %$v_options ) \n"
"#       {\n"
"#	 print STDERR \"key1=[$xx2]\\n\";\n"
"#	 print STDERR \"data1=[\",$v_options->{$xx2},\"]\\n\";\n"
"#       }\n"
"     set_env_vars ($v_options);\n"
"     if(defined $Cache{$package}{mtime}\n"
"        &&\n"
"        $Cache{$package}{mtime} <= $mtime)\n"
"     {\n"
"        # we have compiled this subroutine already,\n"
"        # it has not been updated on disk, nothing left to do\n"
"        print STDERR \"already compiled $package->handler\\n\";\n"
"     }\n"
"     else {\n"
"        local *FH;\n"
"        open FH, $filename or die \"open '$filename' $!\";\n"
"        local($/) = undef;\n"
"        my $sub = <FH>;\n"
"        close FH;\n"
"\n"
"        #wrap the code into a subroutine inside our unique package\n"
"        my $eval = qq{package $package; sub handler { $sub; }};\n"
"        {\n"
"            # hide our variables within this block\n"
"            my($filename,$mtime,$package,$sub);\n"
"            eval $eval;\n"
"        }\n"
"        die $@ if $@;\n"
"\n"
"        #cache it unless we're cleaning out each time\n"
"        $Cache{$package}{mtime} = $mtime unless $delete;\n"
"     }\n"
"\n"
"     eval {$package->handler;};\n"
"     die $@ if ($@ && $@ != '');\n"
"\n"
"     delete_package($package) if $delete;\n"
"\n"
"     return ($stdout_ref->getintext, $stdout_ref->getinhdr, $stderr_ref->getintext);\n"
" }\n"
"\n"
" # static\n"
" sub eval_string {\n"
"     my($filename, $content, $delete, $mtime, $v_options, $v_params, $v_lines) = @_;\n"
"     #print STDERR \"filename=[$filename] content=[$content] delete=[$delete] mtime=[$mtime] v_options=%v_options v_params=%v_params v_lines=\",@v_lines,\"\\n\";\n"
"     my $package = valid_package_name($filename);\n"
"     #my $mtime = -M $filename;\n"
"     $stdout_ref->text_reset;\n"
"     $stderr_ref->text_reset;\n"
"     $stdin_ref->setouttext ($v_params);\n"
"     set_env_vars ($v_options);\n"
"     if(0)\n"
"     {\n"
"        # we have compiled this subroutine already,\n"
"        # it has not been updated on disk, nothing left to do\n"
"        #print STDERR \"already compiled $package->handler\\n\";\n"
"     }\n"
"     else {\n"
"        local($/) = undef;\n"
"        my $sub = $content;\n"
"        close FH;\n"
"\n"
"        #wrap the code into a subroutine inside our unique package\n"
"        my $eval = qq{package $package; sub handler { $sub; }};\n"
"        {\n"
"            # hide our variables within this block\n"
"            my($filename,$mtime,$package,$sub);\n"
"            eval $eval;\n"
"        }\n"
"        die $@ if $@;\n"
"\n"
"        #cache it unless we're cleaning out each time\n"
"        #$Cache{$package}{mtime} = $mtime unless $delete;\n"
"     }\n"
"\n"
"     eval {$package->handler;};\n"
"     die $@ if ($@ && $@ != '');\n"
"\n"
"     delete_package($package) if $delete;\n"
"\n"
"     return ($stdout_ref->getintext, $stdout_ref->getinhdr, $stderr_ref->getintext);\n"
" }\n"
"\n"
" # instance:  tie members\n"
" sub TIEHANDLE { \n"
"   #print STDERR \"<shout>\\n\"; \n"
"   my $i = {}; \n"
"   text_reset (\\$i);\n"
"   bless \\$i, shift\n"
" }  \n"
"\n"
" sub WRITE {\n"
"   my($self, $buf,$len,$offset) = @_;\n"
"   my $txt = substr (''.$buf, $len, $offset);\n"
"   #print STDERR \"\\n\\n\\n\\n\\n\\nWRITE:\\n\";\n"
"   $$self->{'inbuffer'} .= $txt;\n"
" }\n"
"\n"
" sub PRINT { \n"
"   my $self = shift;\n"
"   my $txt = join ('', @_);\n"
"   #print STDERR \"\\n\\n\\n\\n\\n\\nPRINT\\n\";\n"
"   $$self->{'inbuffer'} .= $txt;\n"
" }  \n"
" \n"
" sub PRINTF {\n"
"   my $self = shift;\n"
"   my $fmt = shift;\n"
"   my $txt = sprintf($fmt, @_);\n"
"   #print STDERR \"\\n\\n\\n\\n\\n\\nPRINTF\\n\";\n"
"   $$self->{'inbuffer'} .= $txt;\n"
" }  \n"
" \n"
"sub FILENO {\n"
"   my $self = shift;\n"
"   return (undef);\n"
"}\n"
"\n"
" sub READ {\n"
"   my $self = shift;\n"
"   my $bufref = \\$_[0];\n"
"   my(undef,$len,$offset) = @_;\n"
"   unless (defined $offset) { $offset = 0; }\n"
"#   print STDERR \"READ called, \\$buf=$bufref, \\$len=$len, \\$offset=$offset\\n\";\n"
"\n"
"   my $out_len = $$self->{'outlen'};\n"
"   my $out_ofs = $$self->{'outofs'};\n"
"   if ($out_ofs >= $out_len)\n"
"     {\n"
"       return 0;\n"
"     }\n"
"   \n"
"   my $to_copy = $len;\n"
"   if ($len > $out_len - $out_ofs)\n"
"     {\n"
"       $to_copy = $out_len - $out_ofs;\n"
"     }\n"
"\n"
"   my $tail = substr ($$bufref, $offset, $to_copy);\n"
"   my $head = substr ($$bufref, 0, $offset);\n"
"   my $chunk = substr ($$self->{'outtext'}, $out_ofs, $to_copy);\n"
"\n"
"#   print STDERR \"READ will return $to_copy chars\\n\";\n"
"   $$bufref = $tail.$chunk.$tail;\n"
"   $$self->{'outofs'} += $to_copy;\n"
"   $to_copy;\n"
" }\n"
" \n"
" sub READLINE { \n"
"   my $self = shift; \n"
"   #print STDERR \"READLINE called $$self times\\n\"; \n"
"   die \"READLINE unimplemented\";\n"
" }  \n"
"\n"
" sub GETC { \n"
"   my $self = shift; \n"
"   if ($$self->{'outofs'} < $$self->{'outlen'})\n"
"     {\n"
"       my $ret = substr ($$self->{'outtext'}, $$self->{'outofs'}, $$self->{'outofs'} + 1);\n"
"       $$self->{'outofs'} += 1;\n"
"       return $ret;\n"
"     }\n"
"\n"
"   return; \n"
" }  \n"
"\n"
" sub BINMODE {\n"
"   my $self = shift; \n"
" }\n"
" \n"
" sub CLOSE { \n"
"   #print STDERR \"CLOSE called.\\n\" \n"
" }  \n"
" \n"
" sub DESTROY { \n"
" }  \n"
"  \n"
" sub tie_all {\n"
"   $stdout_ref = tie(*STDOUT,'VIRT::Embed::Persistent');\n"
"   $stderr_ref = tie(*STDERR,'VIRT::Embed::Persistent');\n"
"   $stdin_ref = tie(*STDIN, 'VIRT::Embed::Persistent');\n"
" }\n"
"\n"
" sub text_reset {\n"
"   my $self = shift;\n"
"   $$self->{'intext'} = '';\n"
"   $$self->{'inbuffer'} = '';\n"
"   $$self->{'inhdr'} = '';\n"
"   $$self->{'outtext'} = '';\n"
"   $$self->{'outofs'} = 0;\n"
"   $$self->{'outlen'} = 0;\n"
"   $$self->{'html_mode'} = 1;\n"
" }\n"
" \n"
" sub parseintext {\n"
"   my $sel = shift;\n"
"   my $txt = $$sel->{'inbuffer'};\n"
"\n"
"   if ($$sel->{'html_mode'} == 0)\n"
"     {\n"
"       $$sel->{'intext'} = $txt;\n"
"       $$sel->{'inhdr'} = '';\n"
"       return $$sel->{'intext'};\n"
"     }\n"
"\n"
"   my $empty_line_idx = index ($txt, \"\\n\\r\\n\");\n"
"   my $len = 3;\n"
"   if ($empty_line_idx == -1)\n"
"     {\n"
"       $empty_line_idx = index $txt, \"\\n\\n\";\n"
"       $len = 2;\n"
"     }\n"
"   if ($empty_line_idx == -1)\n"
"     {\n"
"        $$sel->{'inhdr'} .= '';\n"
"        $$sel->{'intext'} .= $txt;\n"
"	return $txt;\n"
"     }\n"
"   else\n"
"      {\n"
"        $$sel->{'hdrmode'} = 0;\n"
"        my $to_hdr = substr ($txt, 0, $empty_line_idx + $len);\n"
"        my $to_txt = substr ($txt, $empty_line_idx + $len);\n"
"        #print STDERR \"vh: adding [$to_hdr] to hdr, [$to_txt] to txt\\n\";\n"
"        $$sel->{'inhdr'} .= $to_hdr;\n"
"        $$sel->{'intext'} .= $to_txt;\n"
"	return  $$sel->{'intext'};  \n"
"      }\n"
" }\n"
"\n"
" sub getinhdr {\n"
"   my $self = shift;\n"
"   if ($$self->{'intext'} == '' && $$self->{'inhdr'} == '')\n"
"     {\n"
"       $self->parseintext;\n"
"     }  \n"
"   return $$self->{'inhdr'};\n"
" }\n"
"\n"
" sub getintext {\n"
"   my $self = shift;\n"
"   if ($$self->{'intext'} == '' && $$self->{'inhdr'} == '')\n"
"     {\n"
"       $self->parseintext;\n"
"     }  \n"
"   return $$self->{'intext'};\n"
" }\n"
"\n"
" sub setouttext {\n"
"   my $self = shift;\n"
"   $$self->{'outtext'} = shift;\n"
"   $$self->{'outofs'} = 0;\n"
"   $$self->{'outlen'} = length ($$self->{'outtext'});\n"
" }\n"
" \n"
"  my @virt_env;\n"
"\n"
"  sub TIEHASH {\n"
"    my $self = shift;\n"
"    my $org_hash = shift;\n"
"#    print STDERR \"TIEHASH\\n\";\n"
"\n"
"    my $inst = {\n"
"      LIST => {}\n"
"    };\n"
"    $inst->{LIST} = $org_hash;\n"
"  }\n"
"\n"
"  sub FETCH {\n"
"    my ($self, $key) = @_;\n"
"#    print STDERR \"FETCH key=[$key]\\n\";\n"
"\n"
"    return $self->{LIST}->{$key};\n"
"  }\n"
"    \n"
"  sub STORE {\n"
"    my ($self, $key, $value) = @_;\n"
"#    print STDERR \"STORE key=[$key] val=[$value]\\n\";\n"
"\n"
"    my $mm2 = $self->{LIST};\n"
"    my %mm = %$mm2;\n"
"    $self->{LIST}->{$key} = $value;\n"
"  }\n"
"    \n"
"  sub DELETE {\n"
"    my ($self, $key) = @_;\n"
"#    print STDERR \"DELETE\\n\";\n"
"\n"
"    return delete $self->{LIST}->{$key};\n"
"  }\n"
"\n"
"  sub CLEAR {\n"
"    my $self = shift;\n"
"#    print STDERR \"CLEAR\\n\";\n"
"    foreach my $key (keys %{$self->{LIST}}) {\n"
"      $self->DELETE ($key);\n"
"    }\n"
"  }\n"
"\n"
"  sub EXISTS {\n"
"    my ($self, $key) = @_;\n"
"#    print STDERR \"EXISTS key=[$key]\\n\";\n"
"    return exists $self->{LIST}->{$key};  \n"
"  }\n"
"\n"
"  sub FIRSTKEY {\n"
"    my $self = shift;\n"
"#    print STDERR \"FIRSTKEY\\n\";\n"
"    my $a = keys %{$self->{LIST}};\n"
"    each %{$self->{LIST}};\n"
"  }\n"
"\n"
"  sub NEXTKEY {\n"
"    my ($self, $lastkey) = @_;\n"
"#    print STDERR \"NEXTKEY\\n\";\n"
"    each %{$self->{LIST}};\n"
"  }\n"
"\n"
"  sub exit {\n"
"#    print STDERR \"EXIT called\\n\";\n"
"    die \"\";\n"
"  }\n"
"\n"
"  @virt_env = {};\n"
"  tie %ENV, 'VIRT::Embed::Persistent', @virt_env;\n"
"  tie_all ();\n"
"  *CORE::GLOBAL::exit = \\&VIRT::Embed::Persistent::exit;\n"
"1;\n"
"\n"
"__END__\n"
;
