lire 2:2.1.1-2.1 / usr / share / perl5 / Lire / XMLSpecContainer.pm

package Lire::XMLSpecContainer;

use strict;

use Lire::DlfSchema;
use Lire::DataTypes qw/ check_superservice check_xml_name /;
use Lire::Utils qw/ xml_encode check_param check_object_param /;
use Lire::I18N qw/ dgettext dgettext_para /;
use Lire::Config::XMLSpecListSpec;
use Lire::XMLSpecParser;

use Carp;


=pod

=head1 NAME

Lire::XMLSpecContainer - Base clase for XML report and filter specifications

=head1 SYNOPSIS

  use base qw/Lire::XMLSpecContainer/;

=head1 DESCRIPTION

This is the base class for Lire::ReportSpec and Lire::FilterSpec which
are XML specifications used to compute reports. This man page document
the attributes common to both type of specification.

=cut

sub load {
    my ( $self, $super, $id ) = @_;

    check_param( $super, 'super', \&check_superservice );

    check_param( $id, 'id', \&check_xml_name );

    my $file = $self->file_from_id( $super, $id );
    my $parser = new Lire::XMLSpecParser();
    my $spec = eval { $parser->parsefile( $file ) };
    croak "error while parsing XML specification $id: $@"
      if $@;

    # Some sanity checks
    croak "$file has superservice '", $spec->superservice(), "' when it
      should be '", $super, "'\n" unless $spec->superservice() eq $super;
    croak "$file has id '", $spec->id(), "' when it should be '", $id, "'\n"
      unless $spec->id() eq $id;

    return $spec;
}

sub new {
    return bless { 'params' => {},
                   '_joined_schemas' => [],
                 }, shift;
}

=pod

=head2 id( [ $new_id ] )

Returns the type id of this specification. It $new_id is set, it will
change the id of the specification.

=cut

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

    if ( defined $id ) {
        check_param( $id, 'id', \&check_xml_name );

	$self->{'id'}	= $id;
    }

    return $self->{'id'};
}

=pod

=head2 superservice( [ $new_superservice ] )

Returns the superservice (aka base DLF schema) used by this
specification. It $new_superservice is set, it will change the
superservice of the specification.

=cut

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

    if ( defined $superservice ) {
        check_param( $superservice, 'superservice', \&check_superservice );

	# Schema can't be valid if we switch superservice
	delete $self->{'schema'}
	  if defined $self->{'superservice'} &&
	    $self->{'superservice'} ne $superservice;

	$self->{'superservice'} = $superservice;
    }

    return $self->{'superservice'};
}

=pod

=head2 schema( [ $new_schema ] )

Returns the Lire::DLfSchema object used by this specification. This
can be the superservice or any of its Lire::ExtendedSchema or
Lire::DerivedSchema.

If $new_schema is a string, the specification's schema will be changed
to that schema. If $new_schema is undef, the base DlfSchema (aka
superservice) will be used.


=cut

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

    if ( @_ == 2 ) {
	if (defined $schema) {
	    my ( $super ) = $schema =~ /^(\w+)-/;
	    croak "invalid schema identifier: $schema"
	      unless $super;
	    croak "superservice of schema isn't correct: $super != $self->{'superservice'}"
	      unless $super eq $self->{'superservice'};
	    $self->{'schema'} = $schema;
	} else {
	    delete $self->{'schema'};
	}
    }

    return Lire::DlfSchema::load_schema( $self->{'schema'} ||
					 $self->{'superservice'} );
}


=pod

=head2 joined_schemas( [ $new_schemas ] )

Returns as an array reference, the list of schemas that are joined in
this specification.

If $new_schemas is set, the list of joined schemas will be changed to
that list. This is an array reference of schema name. All of these
schemas should be join compatible with the schema specified in the
schema() attribute.

=cut

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

    if ( defined $new_schemas ) {
        check_object_param( $new_schemas, 'new_schemas', 'ARRAY' );

        my $schema = $self->schema();
        foreach my $name ( @$new_schemas ) {
            croak "no schema '$name'"
              unless Lire::DlfSchema->has_schema( $name );
            my $joined = Lire::DlfSchema::load_schema( $name );
            croak "cannot join '$name' schema with '" . $schema->id() . "'"
              unless $self->schema()->can_join_schema( $joined );
        }
        @{$self->{'_joined_schemas'}} = @$new_schemas;
    }
    return $self->{'_joined_schemas'};
}

=pod

=head2 schemas()

Returns in an array reference all the schemas used by this
specification. This will include the base schema as well as any
joined schemas.

=cut

sub schemas {
    my $self = $_[0];

    return [ $self->schema()->id(), @{$self->{'_joined_schemas'}} ];
}

=pod

=head2 has_field( $name ) 

Returns whether the field named $name is available in this
specification's schema or any of its joined schema.

=cut

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

    check_param( $name, 'name' );

    return 1 if $self->schema()->has_field( $name );

    foreach my $schema_name ( @{$self->{'_joined_schemas'}} ) {
        my $schema = Lire::DlfSchema::load_schema( $schema_name );
        return 1 if $schema->has_field( $name );
    }

    return 0;
}

=pod

=head2 field( $name )

Returns the Lire::Field object named $name present in one of
the specification's joined schema.

=cut

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

    check_param( $name, 'name' );

    croak ( "no field '$name' in this specification's schemas: " .
            join( ", ", $self->schema()->id(), @{$self->{'_joined_schemas'}} ))
      unless $self->has_field( $name );

    return $self->schema()->field( $name )
      if $self->schema()->has_field( $name );

    foreach my $schema_name ( @{$self->{'_joined_schemas'}} ) {
        my $schema = Lire::DlfSchema::load_schema( $schema_name );
        return $schema->field( $name ) if $schema->has_field( $name );
    }

    die "ASSERT: shouldn't be reached";
}

=pod

=head2 title( [ $new_title ]

This method returns the title of this specification. If $new_title is
set, the specification's title will be changed to that value.

The returned value is localized if a translation string is available.
The domain used for translation is 'lire-<superservice'.

=cut

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

    if ( defined $title ) {
	$self->{'title'} = $title;
    }

    return dgettext( 'lire-' . $self->superservice(),
                     $self->{'title'} );
}


=pod

=head2 description( [ $new_description ]

This method returns the description of this specification. If
$new_description is set, the specification's description will be
changed to that value. That description is a DocBook string describing
the specification's purpose.

The returned value is localized if a translation string is available.
The domain used for translation is 'lire-<superservice'.

=cut

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

    if ( defined $desc ) {
	$self->{'description'} = $desc;
    }

    return dgettext_para( 'lire-' . $self->superservice(),
                          $self->{'description'} );
}

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

    return exists $self->{'params'}{$name};
}

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

    if ( defined $param ) {
	croak "param has invalid name $name != " . $param->name()
	  unless $name eq $param->name();
	$self->{'params'}{$name} = $param;
    }

    croak "Lire::XMLSpecContainer::param: no param $name defined"
      unless $self->has_param( $name );

    my $p = $self->{'params'}{$name};

    if ( @_ == 3 && ! defined $param) {
	# Remove it
	delete $self->{'params'}{$name};
    }

    return $p;
}

sub param_names {
    my ( $self ) = @_;

    return map { $_->name() } values %{$self->{'params'}};
}

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

    return undef unless (defined $value);

    if ( substr( $value, 0, 1) eq '$') {
        my $pname = substr( $value, 1);
        croak "no such parameter: '$pname'"
          unless (defined $self->{'params'}{$pname});
        return $self->{'params'}{$pname}->value();
    } else {
        return $value;
    }
}

=pod

=head2 display_title( [ $new_title ]

This method returns the title that will be displayed in the generated
specification. This value can contains reference to the
specification's parameters using the '$name' syntax.

If $new_title is set, the specification's display title will be changed
to that value.

The returned value is localized if a translation string is available.
The domain used for translation is 'lire-<superservice'.

=cut

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

    if ( defined $title ) {
	my @wrong = $self->check_params( $title );
	if ( @wrong == 1 ) {
	    croak "non-existent parameter '", $wrong[0],
	      "' used in display title\n";
	} elsif ( @wrong > 1 ) {
	    croak "non-existent parameters (", join( ", ", @wrong ),
	      ") are used in display title\n";
	}
	$self->{'display_title'} = $title;
    }

    return dgettext( 'lire-' . $self->superservice(),
                     $self->{'display_title'} );
}

=pod

=head2 display_description( [ $new_description ]

This method returns the description that will be displayed in the
generated report. This value can contains reference to the
specification's parameters using the '$name' syntax.

If $new_description is set, the specification's description will be
changed to that value. That description is a DocBook string describing
the specification's purpose.

The returned value is localized if a translation string is available.
The domain used for translation is 'lire-<superservice'.

=cut

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

    if ( @_ == 2 ) {
	my @wrong = $self->check_params( $desc );
	if ( @wrong == 1 ) {
	    croak "non-existent parameter '", $wrong[0],
	      "' used in display description\n";
	} elsif ( @wrong > 1 ) {
	    croak "non-existent parameters (", join( ", ", @wrong ),
	      ") are used in display description\n";
	}

	# Modify the description
	$self->{'display_description'} = $desc;
    }

    return dgettext_para( 'lire-' . $self->superservice(),
                          $self->{'display_description'} );
}

=pod

=head2 expanded_display_title()

Returns display_title() with parameters reference expanded.

=cut

sub expanded_display_title {
    my $self = $_[0];

    return $self->expand_params( $self->display_title() );
}

=pod

=head2 expanded_display_description()

Returns display_description() with parameters reference expanded.

=cut

sub expanded_display_description {
    my ( $self ) = @_;

    return $self->expand_params( $self->display_description() );
}

# ------------------------------------------------------------------------
# Method check_params($str)
#
# Extracts the $ parameters contained in $str and returns the
# list of parameter which aren't available.
# 
# Returns the empty list if all parameters are valid
sub check_params {
    my ($self, $str ) = @_;

    my @wrong = ();
    my @params = $str =~ m|(?<!\$)\$([a-zA-Z]+[-:.\w]+)|g;
    foreach my $p ( @params ) {
	push @wrong, $p
	  unless $self->has_param( $p );
    }

    return @wrong;
}

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

    return $str if ( ! defined $str );

    # Replace all occurence of $name with the value of the
    # parameter with the same name. Ignore $$name which will become $name.
    # Will croak on non-existent parameters.
    $str =~ s{(?<!\$)\$([a-zA-Z]+[-:.\w]+)}{$self->param($1)->value()}eg;

    # Unescape $$
    $str =~ s{\$\$}{\$}g;

    return $str;
}

=pod

=head2 print( $fh )

Prints this specification as XML on $fh.

=cut

sub print {
    my ($self, $fh) = @_;
    $fh ||= \*STDOUT;

    my $root = $self->root_element();
#
# The header
#
    print $fh <<EOF;
<?xml version="1.0"?>
<!DOCTYPE lire:$root PUBLIC
  "-//LogReport.ORG//DTD Lire Report Specification Markup Language V2.1//EN"
  "http://www.logreport.org/LRSML/2.1/lrsml.dtd">
EOF
    print $fh qq{<lire:$root xmlns:lire="http://www.logreport.org/LRSML/" xmlns:lrcml="http://www.logreport.org/LRCML/" id="$self->{'id'}" superservice="$self->{'superservice'}"};
    print $fh qq{ schema="$self->{'schema'}"}
      if defined $self->{'schema'};
    print $fh $self->root_xml_attrs();
    print $fh ">\n\n";

#
# Title and description
#
    my $title = xml_encode( $self->{'title'} );
    print $fh <<EOF;
 <lire:title>$title</lire:title>
 <lire:description>$self->{'description'}</lire:description>

EOF

#
# Parameter specifications
#
    if ( keys %{$self->{'params'}}) {
	print $fh " <lire:param-spec>\n";

	foreach my $p ( values %{$self->{'params'}} ) {
	    my $name = $p->name();
	    my $type = $p->type();
	    my $default = xml_encode( $p->default() );
	    my $desc = $p->description();
	    print $fh qq{  <lire:param name="$name" type="$type"};
	    print $fh qq{ default="$default"}
	      if defined $default;
	    if (defined $desc ) {
		print $fh <<EOF;
>
   <lire:description>$desc</lire:description>
  </lire:param>

EOF
	    } else {
		print $fh "/>\n\n";
	    }
	}
	print $fh " </lire:param-spec>\n";
    }


#
# Display-spec
#
    my $display_title = xml_encode( $self->{'display_title'} );
    print $fh <<EOF;
 <lire:display-spec>
  <lire:title>$display_title</lire:title>

EOF

    print $fh "   <lire:description>\n", $self->display_description,
      "   </lire:description>\n\n"
	if $self->display_description;

    print $fh <<EOF;
 </lire:display-spec>

EOF

    $self->print_children( $fh, 1 );

    print $fh <<EOF;
</lire:$root>
EOF
    return;
}

sub has_spec {
    my ( $self, $super, $id ) = @_;

    check_param( $super, 'superservice', \&check_superservice );
    check_param( $id, 'id', \&check_xml_name );

    foreach my $dir ( @{$self->spec_path()} ) {
        return 1 if -f "$dir/$super/$id.xml";
    }

    return 0;
}

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

    check_param( $super, 'superservice', \&check_superservice );

    my %result = ();
    foreach my $dir ( @{$self->spec_path()} ) {
        next unless -d "$dir/$super" && -r "$dir/$super";
        opendir my $dh, "$dir/$super"
          or die "opendir failed: $!\n";
        foreach my $file ( readdir $dh ) {
            next unless $file =~ /^([a-zA-Z][a-zA-Z0-9._-]+)\.xml$/;
            $result{$1} = 1;
        }
        closedir $dh;
    }

    return [ keys %result ];

}

sub file_from_id {
    my ( $self, $super, $id ) = @_;

    check_param( $super, 'superservice', \&check_superservice );
    check_param( $id, 'id', \&check_xml_name );

    foreach my $dir ( @{$self->spec_path()} ) {
        return "$dir/$super/$id.xml" if -f "$dir/$super/$id.xml";
    }

    croak(  "can't find '$super' ", ref $self || $self,
            " XML specification '$id' in \"",
            join( ":", @{$self->spec_path()} ), '"' );
}

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

    my $def = $value->Lire::Config::Dictionary::as_value();
    my ( $super, $type ) =
      $value->name() =~ qr/$Lire::Config::XMLSpecListSpec::NAME_RE/;
    my $spec = $self->load( $super, $type );

    $spec->display_title( $def->{'title'} ) if $def->{'title'};
    foreach my $name ( $spec->param_names() ) {
        $spec->param( $name )->value( $def->{$name} );
    }

    return $spec;
}

########################################################################
#			 METHODS TO OVERRIDE
########################################################################

sub print_children {
    my ( $self, $fh, $indent ) = @_;

    croak "unimplemented method: ", ref $self || $self, "::print_children\n";
}

sub spec_path {
    croak "unimplemented method: ", ref $_[0] || $_[0], "::spec_path\n";
}

sub root_element {
    my ( $self ) = @_;

    croak "unimplemented method: ", ref $self || $self, "::root_element\n";
}

sub root_xml_attrs {
    return "";
}

1;

__END__

=pod

=head1 SEE ALSO

 Lire::ReportSpec(3pm), Lire::FilterSpec(3pm), Lire::XMLSpecParser(3pm)

=head1 AUTHORS

  Francis J. Lacoste <flacoste@logreport.org>
  Wolfgang Sourdeau <wolfgang@logreport.org>

=head1 VERSION

$Id: XMLSpecContainer.pm,v 1.41 2006/07/23 13:16:30 vanbaal Exp $

=head1 COPYRIGHT

Copyright (C) 2001-2004 Stichting LogReport Foundation LogReport@LogReport.org

This file is part of Lire.

Lire is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program (see COPYING); if not, check with
http://www.gnu.org/copyleft/gpl.html. 


=cut