in reply to Using Perl to create XML

I'm not familliar with the XML specification, but if you gave a true set of sample data, this quick hack would be able to produce that.

First the script: 
#!/usr/local/bin/perl -w
#Script
use strict;
use OOXML;
my $xmldoc = new OOXML("house");
my $groundfloor = $xmldoc->node("groundfloor");
my $kitchen = $groundfloor->node("room", name=>"kitchen");
my $lounge = $groundfloor->node("room", name=>"lounge");
$kitchen->tag("item",name=>"cooker", colour=>"white");
$lounge->tag("item",name=>"sofa",colour=>"turgid brown");
$kitchen->tag("item",name=>"sink",colour=>"silver");
$lounge->tag("item",name=>"chair",colour=>"lime green");
print "First example... Matches yours\n";
$xmldoc->write();
my $secfloor = $xmldoc->node("2ndfloor", level => 2);
my $bedroom = $secfloor->node("room", name=>"Bedroom 1", size=>"400 sq
+ ft");
my $bathroom = $secfloor->node("room", name=>"Bathroom", size=>"1/2");
$bedroom->tag("furniture",name=>"bed",colour=>"mahogony");
$bedroom->tag("furniture",name=>"dresser", colour=>"black");
$bedroom->tag("fixture", name=>"ceiling fan", colour=>"gold", action=>
+"rotation");
$bathroom->tag("item", name=>"washcloth",colour=>"blue");
$bathroom->tag("furniture",name=>"sink", colour=>"white");
$bathroom->tag("furniture",name=>"toilet", colour=>"white");
my $saying = $bathroom->text(nodename=>"walldecor", name=>"saying");
$saying->text(text =>"If at first you don't fricasee; fry, fry a hen."
+);
$saying->text(nodename=>"strong",text=>"!!!!");
$saying->text(text =>"After the strong tag");
print "\n\n\nSecond example... more functionality\n";
$xmldoc->write();
print "\n\n\nThird example... set the increase(10) and starting(5) ind
+ent levels\n";
$xmldoc->write(10,5);
print "\n\n\nFourth example... Going to a file \"out.xml\"\n";
$xmldoc->write('','',"out.xml");

[download]




And then the module

#!/usr/local/bin/perl -w
# Module
package OOXML;
use strict;

sub new {
    my ( $class, $root, %params ) = @_;
    my $self={};
    $self->{name} = $root;
    $self->{nodes} = ();
    $self->{tags} = ();
    $self->{params} = {};
    if ( defined %params ) {
    for my $param ( keys %params ) {
        $self->{params}{$param} = $params{$param};
    }
    }
    $self->{params}{type} = "main" if ( ! exists $self->{params}{type}
+ );

    return bless $self, $class;
}

sub node { 
    my ( $self, $node, %params ) = @_;
    push @{$self->{nodes}}, $self->new($node,type =>"node",%params);
    return bless $self->{nodes}[-1];
}

sub tag {
    my ( $self, $tag, %params ) = @_;
    push @{$self->{tags}}, $self->new($tag,type=>"tag",%params);
    return bless $self->{tags}[-1];
}
sub text {
    my ( $self, %params ) = @_;
    push @{$self->{nodes}}, $self->new("textnode",type=>"text",%params
+);
    return bless $self->{nodes}[-1];
}
sub write {
    my ( $self, $levelup, $level,$doc,$class ) = @_;
    my $node;
    $level = 0 if ( ! defined $level ) || $level eq "";
    $levelup = 4 if ( ! defined $levelup ) || $levelup eq "";
    if ( defined $doc ) {
    open STDOUT, ">>$doc" || return (1,"Couldn't open output file: $!"
+);
    }
    print "\n" if ( $self->{params}{type} ne "text" && defined $class 
+&& $class->{params}{type} eq "text" ) ;
    print " " x $level if ($self->{params}{type} !~ /^text$/);
    print " " x $level if ($self->{params}{type} eq "text" && $class->
+{name} ne "textnode");
    if ( $self->{params}{type} eq "text" ) {
    if ( exists $self->{params}{nodename} ) {
        print "<$self->{params}{nodename}";
        for my $param ( keys %{$self->{params}} ) {
        next if ( $param eq "type" || $param eq "nodename" || $param e
+q "text" );
        print " $param=\"$self->{params}{$param}\"";
        }
        print ">";
    }
    print "$self->{params}{text}" if ( exists $self->{params}{text} );
    }else {
    print "<$self->{name}";
    for my $param ( keys %{$self->{params}} ) {
        next if $param eq "type";
        print " $param=\"$self->{params}{$param}\"";
    }
    print ">\n";
    }
    my $test = 0;
    my $lastnode;
    for $node ( @{$self->{nodes}} ) {
    bless $node;
    print "\n" if $node->{name} ne "textnode" and ($test == 12);
    $test = $node->write($levelup, $level+$levelup, $doc, $self);
    $lastnode = bless $node;
    }
    for my $tag ( @{$self->{tags}} ) {
    bless $tag;
    if ( defined $lastnode && $lastnode->{name} eq "textnode" ) {
        print "\n";
        undef $lastnode;
    }
    print " " x ( $level + $levelup) . "<$tag->{name}";
    for my $param ( keys %{$tag->{params}} ) {
        next if $param eq "type";
        print " $param=\"$tag->{params}{$param}\"";
    }
    print ">\n";
    }
    if ( $self->{params}{type} eq "text") {
    if ( exists $self->{params}{nodename} ) {
        print "</$self->{params}{nodename}>";
    }
    return 12;
    } else {
    print "\n" if ( defined $node && $node->{name} eq "textnode");
    print " " x $level . "</$self->{name}>\n";
    }
    return 0;
}
1;

[download]

Course it would be stupid to use this when there are peer reviewed/tried and true modules out there, that probably also adhere to the standard ( which this doesn't... lets you do pretty much whatever you want )... but it only took m a few minutes to throw together, so...

Replies are listed 'Best First'.
Re^2: Using Perl to create XML
by theophanie77 (Novice) on Apr 14, 2011 at 17:37 UTC
    Hi raflach, I tried to use your perl but adding the OOXML module through a "require" comand inside the calling perl. It fails for : "Attempt to bless into a reference at /...OOXML.pl line 21", which is the "return bless $self, $class" line. I tried without success with the lines : 
    bless $self, $class;
return $self

    [download]
    What is the problem ? Thanks Jean-michel, Nemours, FRANCE
[reply]
[d/l]
      What is the problem ?

      Allow me to introduce you to splain, a command-line interface to perldiag. 

      C:\>splain
C:\Perl\bin/splain.bat: Reading from STDIN
Attempt to bless into a reference
Attempt to bless into a reference (#1)
    (F) The CLASSNAME argument to the bless() operator is expected to 
+be
    the name of the package to bless the resulting object into. You've
    supplied instead a reference to something: perhaps you wrote

        bless $self, $proto;

    when you intended

        bless $self, ref($proto) || $proto;

    If you actually want to bless into the stringified version
    of the reference supplied, you need to stringify it yourself, for
    example by:

        bless $self, "$proto";

      [download]

      So it turns out there is actually a bug in the OOXML.pm file.
      In subs new, tag, and text, he calls $self->new(...) which is precisely the trigger for the diagnostic above.
      Probably the easiest way to fix this is just to change return bless $self, $class; into return bless $self;
      That's not robust if OOXML is going to be subclassed, however. In that case, I'd recommend the following simple change instead:

      In sub new, immediately after the my( $class, ... line, insert the following line: 

          $class = ref($class) if ref($class);

      [download]

      I reckon we are the only monastery ever to have a dungeon stuffed with 16,000 zombies.
[reply]
[d/l]
[select]
        Hi jdporter, Using the "return bless $self" syntax, it works now ! Thank you very much. Jean-michel
[reply]

In Section Seekers of Perl Wisdom