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

package Lire::DlfSchema;

use strict;

use vars qw/ %SCHEMA_CACHE /;

use Carp;
use Locale::TextDomain 'lire';
use XML::Parser;

use Lire::Config::Build qw/ ac_info /;
use Lire::Config;
use Lire::DataTypes qw/ check_xml_name check_superservice check_type /;
use Lire::Field;
use Lire::DerivedSchema;
use Lire::ExtendedSchema;
use Lire::DlfQuery;
use Lire::I18N qw/ bindtextdomain dgettext dgettext_para /;
use Lire::Utils qw/ sql_quote_name check_param check_object_param /;

BEGIN {
    %SCHEMA_CACHE = ();
};

=pod

=head1 NAME

Lire::DlfSchema - Interface to Lire DLF Schema XML specifications

=head1 SYNOPSIS

In DLF converters:

    use Lire::DlfSchema;

    my $schema = Lire::DlfSchema::load_schema( "email" );
    my $fields = $schema->fields();

    my $dlf_id = $schema->field( 'dlf_id' );
    my $dlf_src = $schema->field( 'dlf_source' );

=head1 DESCRIPTION

This module is the interface to the Lire DLF Schemas defined in XML
files. A schema defines the order of the fields along with their
names, descriptions and types.

Each DlfSchema have at least two predefined fields: 

=over

=item dlf_id

This is an integer which uniquely identify a DLF record in its stream.
Its used to link the record to its extended schemas fields and also to
link the record to the derived schemas records.

=item dlf_source

This is an identifier which can be used to track the record the
ImportJob that created it.

=back

=head1 ACCESSING A SCHEMA OBJECT

The way to access a schema for a superservice is through the
load_schema() module function. You use it like this:

    my $schema = Lire::DlfSchema::load_schema( $superservice);

This function will return a schema object which can then be used to
query information about the schema. This function will die() on error.

=cut


sub load_schema {
    my ( $name ) = @_;

    check_param ( $name, 'name', \&check_xml_name,
                  'invalid schema identifier' );

    my $super = $name;
    if ($name =~ /^(\w+)-/ ) {
	$super = $1;
    }

    croak "invalid superservice: $super"
      unless Lire::DlfSchema->has_superservice( $super );

    return $SCHEMA_CACHE{$name}
      if $SCHEMA_CACHE{$name};

    my $file = Lire::DlfSchema->_schema_file( $name );
    croak "can't find XML schema definition for $name in ",
      join( ":", @{Lire::Config->get( 'lr_schemas_path' )} ),"\n"
        unless defined $file;

    my $file_h;
    open ( $file_h, "$file")
      or croak "can't open XML schema $file for $name schema: $!";

    my $parser = new XML::Parser ( 'Handlers'	=> {
						    'Init'  => \&Init,
						    'Final' => \&Final,
						    'Start' => \&Start,
						    'End'   => \&End,
						    'Char'  => \&Char,
						   },
				   'Namespaces' => 1,
				   'NoLWP'      => 1,
				 );
    my $dlf_schema = eval { $parser->parse( $file_h ) };
    croak "error while parsing XML definition of $name: $@"
      if $@;
    close $file_h;

    # Sanity checks
    croak "$file has '", $dlf_schema->superservice(), "' as superservice attribute when it should have '", $super, "'\n"
	if $dlf_schema->superservice() ne $super;
    croak "$file has '", $dlf_schema->id(), "' as id attribute when it should have '", $name, "'\n"
      if $dlf_schema->id() ne $name;

    return $SCHEMA_CACHE{$name} = $dlf_schema;
}

sub new {
    my ( $class, %attr ) = @_;

    check_param( $attr{'superservice'}, 'superservice',
                 \&check_superservice );
    check_param( $attr{'timestamp'}, 'timestamp',
                 \&check_xml_name );

    my $self = bless { 'id'		 => $attr{'superservice'},
                       'superservice'    => $attr{'superservice'},
                       'timestamp_field' => $attr{'timestamp'},
                       'fields_by_pos'   => [],
                       'fields_by_name'  => {},
                       'title'	    => undef,
                       'description'	    => undef,
                     }, $class;

    $self->add_field( new Lire::Field( 'name' => 'dlf_id',
                                       'type' => 'id',
                                       'label' => __( 'Dlf ID' ),
                                       'description' => '<para>' . __( <<EOD ) . '</para>'  ) );
This field contains an integer which uniquely identify this DLF record
in the stream.
EOD

    $self->add_field( new Lire::Field( 'name' => 'dlf_source',
                                       'type' => 'string',
                                       'label' => __( 'Dlf Source' ),
                                       'description' => '<para>' . __( <<EOD ) . '</para>'  ) );
This field contains an identifier relating the record to the process
that created it.
EOD

    bindtextdomain( "lire-" . $self->superservice(),
                    ac_info( 'LR_PERL5LIB' ) . "/LocaleData" );

    return $self;
}

sub check {
    my ( $self ) = @_;
    # Verify that the schema is valid

    # Check that the timestamp attribute is valid
    croak ( "field $self->{'timestamp_field'} doesn't exists" )
      unless $self->has_field( $self->{'timestamp_field'} );

    my $field = $self->timestamp_field;
    croak ( "field $self->{'timestamp_field'} isn't of type timestamp" )
      unless $field->type() eq "timestamp";

    return 1;
}

=pod

=head2 has_superservice( $superservice )

Returns true if there is superservice named $schema_name available. An
error will be thrown if the schema name isn't valid for a superservice.

=cut

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

    check_param( $superservice, 'superservice',
                 sub { return ( check_xml_name($_[0])
                                && index($_[0], "-") == -1 ) },
                 'invalid superservice schema name' );

    return ( defined $SCHEMA_CACHE{$superservice}
             || defined $self->_schema_file( $superservice ) );
}

=pod

=head2 has_schema( $schema_name )

Returns true if there is $schema_name available. An error will be
thrown if the schema name isn't valid.

=cut

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

    check_param( $schema_name, 'schema_name', \&check_xml_name,
                 'invalid schema name' );

    return ( defined $SCHEMA_CACHE{$schema_name} 
             ||defined $self->_schema_file( $schema_name ) );
}

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

    foreach my $dir ( @{Lire::Config->get( 'lr_schemas_path' )} ) {
        return "$dir/$schema_name.xml"
          if -f "$dir/$schema_name.xml";
    }

    return undef;
}

=pod

=head2 superservices()

Returns the name of the available superservices in an array.

=cut

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

    return grep { /^[^-]+$/ } $self->schemas();
}

=pod

=head2 schemas()

Returns the name of the available schemas in an array.

=cut

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

    my @schemas = keys %SCHEMA_CACHE;
    foreach my $dir ( @{ Lire::Config->get( 'lr_schemas_path' ) } ) {
        next unless -d $dir && -r $dir;
        opendir my $dh, $dir
          or croak "opendir failed on '$dir': $!";
        foreach my $file ( readdir $dh ) {
            next unless $file =~ /^([a-zA-Z][-\w.:]+)\.xml$/;
            push @schemas, $1
              unless grep { $_ eq $1 } @schemas;
        }
        closedir $dh;
    }

    return @schemas;
}

=pod

=head1 SCHEMA OBJECT METHODS

=head2 id()

    my $id = $schema->id();

This method will return the id of the schema. This will be the
superservice's name for superservice's main schema. (There are other
types of schemas (derived and extended schemas) for which the id will be
different than the superservice's name.)

=cut

sub id {
    return $_[0]->{'id'};
}

=pod

=head2 superservice()

    my $super = $schema->superservice();

This method will return the superservice's name of the schema.

=cut

sub superservice {
    return $_[0]->{'superservice'};
}

=pod

=head2 title( [$new_title] )

This method will return (or change) the human readable title of the
schema. (This is the content of the title element in the XML
specification.)

=cut

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

    if ( @_ == 2 ) {
        check_param( $_[1], 'title' );
        $self->{'title'} = $_[1];
    }
    return dgettext( "lire-$self->{'superservice'}", $self->{'title'} );
}

=pod

=head2 description( [$new_description] )

This method will return (or change) the description of the schema.
(This is the content of the description element in the XML
specification.) Be aware that this will most likely contain DocBook
markup.

=cut

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

    if ( @_ == 2 ) {
        $self->{'description'} = $_[1];
    }
    return dgettext_para( "lire-$self->{'superservice'}",
                          $self->{'description'} );
}

=pod

=head2 field_by_pos()

    my $field = $schema->field_by_pos( 0 );

This method takes an integer as parameter and return the field at that
position in the schema. Fields are indexed starting at 0. This method
will die() if an invalid position is passed as parameter.

The method returns a Lire::Field(3pm) object.

=cut

sub field_by_pos {
    my ( $self, $pos ) = @_;
    croak "invalid field number: $pos"
      unless $pos < @{$self->{'fields_by_pos'}} && $pos >= 0;

    return $self->{'fields_by_pos'}[$pos];
}

=pod

=head2 add_field( $field )

Adds the Lire::Field $field to this schema.

=cut

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

    check_object_param( $field, 'field', 'Lire::Field' );

    push @{$self->{'fields_by_pos'}}, $field;
    $self->{'fields_by_name'}{$field->name()} = $field;
    $field->{'pos'} = $#{$self->{'fields_by_pos'}};

    return;
}

=pod

=head2 has_field()

    if ( $schema->has_field( 'test ) ) { 
	print "schema has field 'test'\n"; 
    }

This method takes a string as parameter and returns a boolean value.
That value will be true if there is a field in the schema with that
name, it will be false otherwise.

=cut

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

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


=pod

=head2 field()

    my $field = $schema->field( 'from_email' );

This method takes a field's name as parameter and returns the
Lire::Field(3pm) object describing that field in the schema. The
method will die() if there is no field with that name in the schema.

=cut

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

    croak "no field by that name: $name"
      unless $self->has_field( $name );

    return $self->{'fields_by_name'}{$name};
}

=pod

=head2 fields()

    my $fields = $schema->fields();
    my @fields = $schema->fields();

In array context, this method will return an array containing all the
fields (as Lire::Field(3pm) objects) in the schema. The order of the
fields in the array is the order of the fields in the schema.

In scalar context, it will return an array reference. This method is
more efficient than creating an array. DO NOT MODIFY THE RETURNED
ARRAY.

=cut

sub fields {
    return wantarray ? @{$_[0]{'fields_by_pos'}} : $_[0]{'fields_by_pos'};
}

=pod

=head2 field_names()

Returns the name of the fields in this schema. The names are in the
same order than the fields.

=cut

sub field_names {
    return map { $_->name() } $_[0]->fields();
}

=pod

=head2 field_count()

    my $number_of_field = $schema->field_count;

This method returns the number of fields in the schema.

=cut

sub field_count {
    return scalar @{$_[0]->{'fields_by_pos'}};
}

=pod

=head2 timestamp_field()

    my $time_field = $schema->timestamp_field;

This method will return the Lire::Field(3pm) object representing the
timestamp field in the schema. The timestamp field is the one that
defines the sort order of the DLF records.

=cut

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

    return $self->field( $self->{'timestamp_field'} );
}

=pod

=head2 is_schema_compatible()

    if ( $schema->is_schema_compatible( $other_schema ) ) {

    }

This method takes a Lire::DlfSchema(3pm) object as parameter and returns a
boolean value. That value will be true if the schema passed as parameter is
compatible with the other, it will be false otherwise.

For a superservice's schema, the only compatible schema is an object
representing the same superservice's schema.

=cut

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

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

=pod

=head2 can_join_schema( $schema ) 

Returns true if $schema can be joined with this schema. For a
DlfSchema, this will be true only when $schema is an ExtendedSchema of
this schema.

=cut

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

    check_object_param( $schema, 'schema', 'Lire::DlfSchema' );

    return ( $schema->isa( 'Lire::ExtendedSchema' )
             && $schema->base() eq $self );
}

sub ascii_dlf_escape_field {
    # Escape the value :
    #   replace space with _
    #   replace 8 bit chars with ?
    #   replace control chars with ?
    return $_[0] =~ tr/ \200-\377\000-\037/_?/;
}

# This method is part of the old style, now deprecated, DLF converter API.

# It takes as parameters a list of field's names that are available in
# the DLF output by the converter. (Not all services in a given
# superservice will support the whole or the same subset of the
# superservice's fields. Unsupported fields should contain the value
# C<LIRE_NOTAVAIL> in the output DLF.)

# This method will return an anonymous subroutine that should be used by
# the DLF converter to create the DLF records. The generated subroutine
# takes as parameter a hash reference representing the DLF record to
# create. It returns an array reference representing the DLF record's
# fields. It will make sure that the field's values are in the correct
# order, that the unavailable fields are marked correctly, that missing
# fields are defaulted and that the field's values are escaped
# appropriately.

# The hash's keys should be the DLF record's field names with the value
# of the field associated to the key. All the fields that are available
# (as specified when the method is called) which are undefined or that
# aren't present in the hash will be set in the output DLF record to the
# field's default value specified in the schema. Extra keys in the hash
# will be ignored. Fields that aren't supported (as specified when the
# subroutine was created by the make_hashref2asciidlf_func() method)
# will contain the C<LIRE_NOTAVAIL> value.

# One can write an ASCII DLF by printing the returned array reference
# using a space as the join delimiter:

#     my $dlf = $dlf_maker->( $hash_dlf );
#     print join( " ", @$dlf ), "\n";

# See the SYNOPSIS section for an example.

# Beware!  New DLF convertors should use the Lire::DlfConverterProcess
# interface.
sub make_hashref2asciidlf_func {
    my ( $self, @fields ) = @_;

    my %avail = map { $_ => 1 } @fields;
    my @ascii_dlf_tmpl = ();
    foreach my $field ( @{$self->fields}) {
	push @ascii_dlf_tmpl, [ $field->name, $field->default() ];
    }

    return sub {
	my ($hash) = @_;

	my $dlf = [];
	foreach my $field_tmpl ( @ascii_dlf_tmpl ) {
	    my $name	= $field_tmpl->[0];
	    my $value;
	    if ( $avail{$name} ) {
		if (defined $hash->{$name} && length $hash->{$name}) {
		    $value = $hash->{$name};
		} else {
		    $value = $field_tmpl->[1]; # Use default
		}
		ascii_dlf_escape_field( $value );
	    } else {
		$value = "LIRE_NOTAVAIL";
	    }
	    push @$dlf, $value;
	}

	return $dlf;
    };
}


=pod

=head1 SQL Related Methods

These methods are used to map DLF record into SQL tables.

=head2 sql_table()

Returns the SQL table used to hold the DLF records of this schema.

=cut

sub sql_table {
    my ( $self, $prefix, $suffix ) = @_;

    $prefix = ""
      unless defined $prefix;
    $suffix = ""
      unless defined $suffix;

    return sql_quote_name( $prefix . 'dlf_' . $_[0]->{'id'} . $suffix );
}

=pod

=head2 create_sql_schema( $dlf_store, [ $remove ] )

This will create the SQL schemas necessary to hold the DLF records for
this schema in the Lire::DlfStore. If $remove is true, a DROP TABLE
will be done before creating the schema.

=cut

sub create_sql_schema {
    my ($self, $store, $remove ) = @_;

    check_object_param( $store, 'store', 'Lire::DlfStore' );

    $store->_dbh()->do( "DROP TABLE " . $self->sql_table() )
      if $remove;
    $store->_dbh()->do( $self->_create_sql_table_query() );

    my $idx_sql = sprintf( "CREATE INDEX %s ON %s ( %s )",
                           $self->sql_table( "", "_" . $self->{'timestamp_field'} . "_idx"),
                           $self->sql_table(),
                           $self->{'timestamp_field'} );
    $store->_dbh()->do( $idx_sql );

    return;
}

sub _create_sql_table_query {
    return "CREATE TABLE " . $_[0]->sql_table() . " "
      . $_[0]->_sql_fields_def();
}

=pod

=head2 needs_sql_schema_migration( $dlf_store )

This method will return true if the SQL schema isn't up-to-date in the
DlfStore. The method migrate_sql_schema() can be used to bring the
schema up to date.

=cut

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

    check_object_param( $store, 'store', 'Lire::DlfStore' );

    my $create_sql = $self->_create_sql_table_query();

    # SQLite will remove trailing newline
    chomp $create_sql;

    my $sql = "SELECT sql FROM sqlite_master WHERE type = 'table' AND name=?";
    my $sth = $store->_dbh()->prepare( $sql );
    $sth->execute( $self->sql_table() );
    my $table_def = $sth->fetchrow_arrayref();
    $sth->finish();

    return $table_def && $table_def->[0] ne $create_sql;
}

=pod

=head2 migrate_sql_schema( $dlf_store )

Updates the SQL schemas to the current version.

=cut

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

    check_object_param( $store, 'store', 'Lire::DlfStore' );

    # SQLite doesn't support ALTER TABLE
    # Find the list of fields in common
    my @fields = $self->_find_fields_in_schema( $store );

    # Create temporary backup
    my $sql = sprintf( "CREATE TEMP TABLE %s AS SELECT * FROM %s",
                       $self->sql_table( "temp_" ),
                       $self->sql_table() );
    $store->_dbh()->do( $sql  );

    # Recreate the schema
    $self->create_sql_schema( $store, 1 );

    # Migrate the data
    my @common_fields = ();
    foreach my $f ( @fields ) {
        push @common_fields, $f if $self->has_field( $f );
    }

    $sql = $self->_migration_insert_query( \@common_fields );
    $store->_dbh()->do( $sql );
    $store->_dbh()->do( "DROP TABLE " . $self->sql_table( "temp_" ) );
    return;
}

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

    # Since DBD::SQLite doesn't support the column_info API
    # we run a query to find the fields present in the schema.
    my $sth = $store->_dbh()->prepare( "SELECT * FROM " . $self->sql_table()
                                       . " LIMIT 1" );
    $sth->execute();

    my @fields = @{$sth->{'NAME'}};
    $sth->finish();

    return @fields;
}

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

    # New fields will be set to NULL
    # Old fields aren't migrated

    my $field_list = join (", ", map { sql_quote_name( $_ ) } @$common_fields);
    return sprintf( "INSERT INTO %s (%s) SELECT %s FROM %s",
                    $self->sql_table(),
                    $field_list, $field_list,
                    $self->sql_table( "temp_" ) );
}

sub _sql_fields {
    return $_[0]->fields();
}

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

    my @defs = ();
    foreach my $f ( $self->_sql_fields() ) {
        push @defs, "    " . sql_quote_name( $f->name() ) . " " . 
          $f->sql_type();
    }

    return "(\n" . join( ",\n", @defs ) . "\n)\n";
}


=pod

=head2 dlf_query( $sort_spec )

Returns a Lire::DlfQuery object which can be use to return all DLF
records sorted according to $sort_spec. Sort spec is a white-space
delimited list of sort field names. They must be present in the
current schema. If the field's name is prefixed by '-', descending
sort order will be used.

=cut

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

    my $query = new Lire::DlfQuery( $self->{'id'} );
    foreach my $f ( $self->fields() ) {
        $query->add_field( $f->name() );
    }

    $query->set_sort_spec( $sort_spec )
      if $sort_spec;

    return $query;
}

=pod

=head2 insert_sql_query()

Returns the INSERT SQL statement that should be used to insert DLF
records in the stream. A DBI::st handle prepared with that query needs
to be passed as parameter to execute_insert_query().

=cut

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

    my @fields = map { $_->name() } $self->_sql_fields();
    return "INSERT INTO " . $self->sql_table() . " ("
      . join( ", ", map { sql_quote_name( $_ ) } @fields ) . ") VALUES ("
      . join( ",", ("?") x scalar @fields  ) . ")";
}

=pod

=head2 sql_clean_query( $with_time )

Returns the DELETE statement that can be use to delete the DLF records
in this schema. If $with_time is true, the query can be use for
selective cleaning. One bind timestamp parameter should be passed when
the query is executed and all records which are older than this
timestamp will be deleted.

=cut

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

    my $table = $self->sql_table();
    if ( $with_time ) {
        my $ts_field = sql_quote_name( $self->{'timestamp_field'} );
        return qq{DELETE FROM $table WHERE $ts_field < ?};
    } else {
        return "DELETE FROM $table";
    }
}

=pod

=head2 sql_clean_period_query()

Returns the DELETE statement that can be use to delete the DLF records
in this schema. The query should be passed two bind parameters. These
parameters will be the time boundaries between which records should be
deleted from the schema.

=cut

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

    my $table = $self->sql_table();
    my $ts_field = sql_quote_name( $self->{'timestamp_field'} );
    return qq{DELETE FROM $table WHERE $ts_field >= ? AND $ts_field < ?};
}

use vars qw( $LDSML_NS %LDSML_ELEMENTS );

BEGIN {
    %LDSML_ELEMENTS = map { $_ => 1 } qw( dlf-schema derived-schema
					  extended-schema field
					  title description );
    $LDSML_NS = "http://www.logreport.org/LDSML/";
}

sub Init {
    my ($expat) = @_;

    $expat->{'lire_curr_schema'} = undef;
    $expat->{'lire_curr_field'}  = undef;
    $expat->{'lire_curr_desc'}   = undef;

    return;
}

sub Final {
    my ( $expat ) = @_;

    return $expat->{'lire_curr_schema'};
}

sub Start {
    my ( $expat, $name ) = @_;

    my $ns = $expat->namespace($name);
    $ns ||= ""; # Remove warnings
    if ( $ns eq $LDSML_NS ) {
	# This is one of our element
	error( $expat, "unknown element: $name" )
	  unless exists $LDSML_ELEMENTS{$name};

	{
	    no strict 'refs';

	    my $sub = $name . "_start";
	    $sub =~ s/-/_/g;	# Hyphen aren't allowed in element name

	    $sub->( @_ );
	};
    } else {
	# If we are in lire:description, this is probably a
	# DocBook element, append it to the current description.
	my $lire_desc = $expat->generate_ns_name( "description", $LDSML_NS );
	if ( $expat->within_element( $lire_desc ) ) {
	    $expat->{'lire_curr_desc'} .= $expat->original_string();
	} else {
	    error( $expat, "unknown element: $name" );
	}
    }
    return;
}

sub End {
    my ( $expat, $name ) = @_;

    my $ns = $expat->namespace($name);
    $ns ||= ""; # Remove warnings
    if ( $ns eq $LDSML_NS ) {
	# This is one of our element
	error( $expat, "unknown element: $name" )
	  unless exists $LDSML_ELEMENTS{$name};

	{
	    no strict 'refs';

	    my $sub = $name . "_end";
	    $sub =~ s/-/_/g;	# Hyphen aren't allowed in element name

	    $sub->( @_ );
	}
    } else {
	# If we are in lire:description, this is probably a
	# DocBook element, append it to the current description.
	my $lire_desc = $expat->generate_ns_name( "description", $LDSML_NS );
	if ( $expat->within_element( $lire_desc ) ) {
	    $expat->{'lire_curr_desc'} .= $expat->original_string();
	} else {
	    error( $expat, "unknown element: $name" );
	}
    }
    return;
}

sub Char {
    my ( $expat, $str ) = @_;

    # Character should only appear in title and description
    my $lire_title = $expat->generate_ns_name( "title", $LDSML_NS );
    my $lire_desc  = $expat->generate_ns_name( "description", $LDSML_NS );

    if ( $expat->in_element( $lire_title )) {
	$expat->{'lire_curr_title'} .= $str;
    } elsif ( $expat->within_element( $lire_desc )) {
	# Use original_string because we don't want parsed entities.
	$expat->{'lire_curr_desc'}  .= $expat->original_string();
    }
    return;
}

sub dlf_schema_start {
    my ( $expat, $name, %attr ) = @_;

    eval {
	$expat->{'lire_curr_schema'} = new Lire::DlfSchema( %attr );
    };
    error( $expat, $@ ) if $@;
    return;
}

sub dlf_schema_end {
    my ( $expat, $name ) = @_;
    eval {
	$expat->{'lire_curr_schema'}->check();
    };
    error( $expat, $@ ) if $@;
    return;
}

sub derived_schema_start {
    my ( $expat, $name, %attr ) = @_;

    eval {
	$expat->{'lire_curr_schema'} = new Lire::DerivedSchema( %attr );
    };
    error( $expat, $@ ) if $@;
    return;
}

sub derived_schema_end {
    my ( $expat, $name ) = @_;
    eval {
	$expat->{'lire_curr_schema'}->check();
    };
    error( $expat, $@ ) if $@;
    return;
}

sub extended_schema_start {
    my ( $expat, $name, %attr ) = @_;

    eval {
	$expat->{'lire_curr_schema'} = new Lire::ExtendedSchema( %attr );
    };
    error( $expat, $@ ) if $@;
    return;
}

sub extended_schema_end {
    my ( $expat, $name ) = @_;
    eval {
	$expat->{'lire_curr_schema'}->check();
    };
    error( $expat, $@ ) if $@;
    return;
}

sub error {
    my ( $expat, $msg ) = @_;

    my $line = $expat->current_line();

    croak $msg, " at line ", $line, "\n";
    return;
}

sub field_start {
    my ( $expat, $name, %attr ) = @_;

    check_param( $attr{'name'}, 'name', \&check_xml_name,
                 'invalid field name' );
    check_param( $attr{'type'}, 'type', \&check_type,
                 'invalid value for type attribute' );

    $expat->{'lire_curr_field'} =
      new Lire::Field( 'name' => $attr{'name'},
                       'i18n_domain' => 'lire-'. $expat->{'lire_curr_schema'}->superservice(),
                       'type'	    => $attr{'type'},
                       'label'    => $attr{'label'},
                     );

    return;
}

sub field_end {
    my ( $expat, $name ) = @_;

    $expat->{'lire_curr_schema'}->add_field( $expat->{'lire_curr_field'} );
    delete $expat->{'lire_curr_field'};

    return;
}

sub title_start {
    my ( $expat, $name ) = @_;

    $expat->{'lire_curr_title'} = "";
    return;
}

sub in_schema_element {
    my ( $expat ) = @_;
    my $lire_dlf_schema = $expat->generate_ns_name( "dlf-schema", $LDSML_NS );
    my $lire_ext_schema = $expat->generate_ns_name( "extended-schema",
						    $LDSML_NS );
    my $lire_der_schema = $expat->generate_ns_name( "derived-schema",
						    $LDSML_NS );

    return $expat->in_element( $lire_dlf_schema ) ||
      $expat->in_element( $lire_ext_schema ) ||
      $expat->in_element( $lire_der_schema );

}

sub title_end {
    my ( $expat, $name ) = @_;

    my $lire_field = $expat->generate_ns_name( "field", $LDSML_NS );

    if ( $expat->in_element( $lire_field)) {
	$expat->{'lire_curr_field'}{'title'} = $expat->{'lire_curr_title'};
    } elsif ( in_schema_element( $expat ) ) {
	$expat->{'lire_curr_schema'}{'title'} = $expat->{'lire_curr_title'};
    } else {
	error( $expat, "encountered unexpected title" );
    }
    return;
}

sub description_start {
    my ( $expat, $name ) = @_;

    $expat->{'lire_curr_desc'} = "";
    return;
}

sub description_end {
    my ( $expat, $name ) = @_;

    my $lire_field = $expat->generate_ns_name( "field", $LDSML_NS );

    if ( $expat->in_element( $lire_field)) {
	$expat->{'lire_curr_field'}{'description'} = $expat->{'lire_curr_desc'};
    } elsif ( in_schema_element( $expat )) {
	$expat->{'lire_curr_schema'}{'description'} = $expat->{'lire_curr_desc'};
    } else {
	error( $expat, "encountered unexpected description" );
    }
    return;
}

# keep perl happy
1;

__END__

=pod

=head1 SEE ALSO

Lire::Field(3pm), Lire::ExtendedSchema(3pm), Lire::DlfConverter(3pm),
Lire::DerivedSchema(3pm)

=head1 AUTHOR

  Francis J. Lacoste <flacoste@logreport.org>

=head1 VERSION

$Id: DlfSchema.pm,v 1.58 2006/07/23 13:16:28 vanbaal Exp $

=head1 COPYRIGHT

Copyright (C) 2001, 2002, 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