CGI::Form2XML - Render CGI form input as XML

CGI-Form2XML documentation Contained in the CGI-Form2XML distribution.

Index

Code Index:

NAME

Top

CGI::Form2XML - Render CGI form input as XML

SYNOPSIS

Top



   use CGI::Form2XML;




   my $x = CGI::Form2XML->new();

   $x->ns_prefix("nfd");

   print $x->asXML();

DESCRIPTION

Top

This module provides a method of taking CGI form input and turning it into XML for further processing by another application or storage. Unlike modules such CGI::XML and CGI::XMLForm it produces XML to a fixed schema whose structure is not influenced by the form input. If flexibility as to the structure of the XML data is required you will probably want to consider one of the other modules.

The schema is included in the distribution of this module as "xmlform.xsd".

The module inherits from the CGI module in order to get access to the CGI parameters, so any of the methods of that module can be used.

METHODS

new

The constructor for the class. Returns a blessed object of type CGI::Form2XML. Any arguments provided will be passed to the constructor of CGI.

asXML

Returns the XML document that represents this CGI request. It takes a hashref of arguments whose keys are :

ns_prefix

The namespace prefix that should be used for this document. The default is no namespace.

ns_url

The URL that describes this namespace - the default is 'http://schemas.gellyfish.com/FormData', there is currently nothing at this URL.

omit_info

If this is set to a true value then the 'header' information will not be emitted by asXML().

ns_prefix

Gets and/or sets the namespace prefix as described as an argument to asXML() above.

Returns and/or sets the namespace URL for the document as described as an argument to asXML() above.

omit_info

If this is set to a true value then the 'header' information will not be emitted in the output document.

destination

This is used to set the value of the 'destination' element in the header information of the output document. This may be a URL, email address or some other identifier. Its content is entirely application specific.

sess_id

This sets the 'session id' for this CGI request, it is intended to be a unique identifier for this request and may take the form of a UUID or an MD5 hash or something similar. Its use is application specific.

owner

This sets the value of the 'owner' element in the header information. This is intended to be the e-mail address indicating the contact for this application. The usage of this information is application specific.

AUTHOR

Top

    Jonathan Stowe <jns@gellyfish.com>

COPYRIGHT

Top

This module is free software. It can be used and distributed under the same terms as Perl itself. The Perl license can be found in the file README in the Perl source distribution.

SEE ALSO

Top

  CGI::XMLForm,  CGI::XML
CGI-Form2XML documentation Contained in the CGI-Form2XML distribution. 
#******************************************************************************
#*           
#*                             GELLYFISH SOFTWARE           
#*                                                       
#*
#******************************************************************************
#*
#*          PROGRAM      :   CGI::Form2XML
#*
#*          AUTHOR       :   JNS
#*
#*          DESCRIPTION  :   Render CGI form data as XML
#*
#*****************************************************************************
#*
#*          $Log: Form2XML.pm,v $
#*          Revision 1.3  2004/03/02 20:28:02  jonathan
#*          Put back in CVS
#*
#*          Revision 1.3  2002/07/28 10:10:11  gellyfish
#*          * POD bugette (noticed in new CPAN search)
#*
#*          Revision 1.2  2002/05/25 09:06:30  gellyfish
#*          Release version
#*
#*          Revision 1.1.1.1  2002/05/25 09:02:28  gellyfish
#*          Added to repository
#*
#*
#*
#*****************************************************************************/ 

package CGI::Form2XML;


use strict;

use CGI;
use POSIX qw(strftime);

use vars qw(@ISA $VERSION);

@ISA = qw( 
           CGI
         );

$VERSION = '1.4';


sub new
{
    my ( $proto, @args) = @_;

    my $class = ref($proto) || $proto;


    my $self  = $class->SUPER::new(@args);

    bless $self, $class;


    return $self;
}



sub asXML
{
   my ( $self, $args ) = @_;

   my $xml  = '';
   my $info = '';
   my $items = '';

   my $indent = ' ' x 3;

   my @params = grep !/(?:destination|session_id|owner)/, $self->param();

   my ($referer, $handler, $time, $destination, $session_id, $owner);

   my $ns_prefix = $args->{ns_prefix} || $self->ns_prefix();
   my $ns_url    = $args->{ns_url}    || $self->ns_url();

   my %info;

   my $pref = $ns_prefix ? "$ns_prefix:" : '' ;

   unless ( $self->omit_info() || $args->{omit_info} )
   {
      my %mandatory = (
                         referer   => 1,
                         handler   => 1,
                         timestamp => 1
                      );

      $info{referer} = $self->referer() || '';
      $info{handler} = $self->script_name() || '';

      $info{timestamp}    = strftime("%Y-%d-%mT%H:%M:%S",localtime());     


      $info{destination} = $self->param('destination') || $self->destination() 
                                                      || '';
      $info{session_id}  = $self->param('session_id') || $self->sess_id() || '';
      $info{owner}       = $self->param('owner') || $self->owner() || '' ;

       

      
     for my $item ( keys %info )
     {
       my $indent = $indent x 2;
       
       if ( length $info{$item} )
       {
          $info{$item} = _quote_xml($info{$item});
          
          $info .= "$indent<$pref$item>$info{$item}</$pref$item>\n";
       }
       elsif ($mandatory{$item})
       {
          $info .= "$indent<$pref$item />\n";
       }
     }

     $info = "$indent<${pref}info>\n$info$indent</${pref}info>\n";
  }

  foreach my $param ( @params )
  {
    my $indent = $indent x 2;

    my $value = $self->param($param);

    if (ref $value )
    {
       my $index = 0;
       foreach my $mvalue ( @{$value} )
       {
          $index++;
          $mvalue = _quote_xml($mvalue);
          $items .= qq%$indent<${pref}field name="$param" index="$index">%;
          $items .= "$mvalue</${pref}field>\n";
       }
    }
    else
    {
       $value = _quote_xml($value);
       $items .= qq%$indent<${pref}field name="$param">%;
       $items .= "$value</${pref}field>\n";
    }
  }

  $items = "$indent<${pref}items>\n$items$indent</${pref}items>\n";

  my $ns_att = '';

  
  if ( $ns_url )
  {

    my $prefix_part = '';

    if ($ns_prefix )
    {
       $prefix_part = ":$ns_prefix";
    }
    $ns_att = qq% xmlns$prefix_part="$ns_url"%;
  }

  $xml = "<${pref}form_data$ns_att>\n$info$items</${pref}form_data>\n";

  return $xml;
}


sub ns_prefix
{
    my ( $self, $ns_prefix ) = @_;

    if ( defined $ns_prefix )
    {
       $self->{_private}->{ns_prefix} = $ns_prefix;
    }
    
    return $self->{_private}->{ns_prefix} || '';
}


sub ns_url
{
    my ( $self, $ns_url ) = @_;

    if ( defined $ns_url )
    {
       $self->{_private}->{ns_url} = $ns_url;
    }
    
    my $def_url = 'http://schemas.gellyfish.com/FormData';

    return $self->{_private}->{ns_url} || $def_url;

}


sub omit_info
{
    my ( $self, $omit_info ) = @_;

    if ( defined $omit_info )
    {
       $self->{_private}->{omit_info} = $omit_info;
    }

    return $self->{_private}->{omit_info} || 0;

}


sub destination
{
    my ( $self, $destination ) = @_;    

    if ( defined $destination )
    {
       $self->{_private}->{destination} = $destination;
    }

    return exists $self->{_private}->{destination} ?
                  $self->{_private}->{destination} : '';
}


sub sess_id
{
    my ( $self , $sess_id ) = @_;

    if ( defined $sess_id )
    {
       $self->{_private}->{sess_id} = $sess_id;
    }

    return  exists $self->{_private}->{sess_id} ?
                   $self->{_private}->{sess_id} : '' ;

}


sub owner
{
    my ( $self , $owner ) = @_;

    if ( defined $owner )
    {
       $self->{_private}->{owner} = $owner;
    }

    return  exists $self->{_private}->{owner} ?
                   $self->{_private}->{owner} : '' ;

}

sub _quote_xml 
{
    $_[0] =~ s/&/&amp;/g;
    $_[0] =~ s/</&lt;/g;
    $_[0] =~ s/>/&gt;/g;
    $_[0] =~ s/'/&apos;/g;
    $_[0] =~ s/"/&quot;/g;
    $_[0] =~ s/([\x80-\xFF])/&XmlUtf8Encode(ord($1))/ge;
    return($_[0]);
}

# I borrowed this from CGI::XML which in turn said
# borrowed from XML::DOM

sub _xml_utf8_encode 
{
    my ($n) = @_;
    if ($n < 0x80) 
    {
        return chr ($n);
    } 
    elsif ($n < 0x800) 
    {
        return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80));
    } 
    elsif ($n < 0x10000) 
    {
        return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80),
                     (($n & 0x3f) | 0x80));
    } 
    elsif ($n < 0x110000) 
    {
        return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80),
                     ((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80));
    }

    return $n;
}


1;
__END__