SWISH::Prog::Aggregator::Object - index Perl objects with Swish-e

    my $aggregator = SWISH::Prog::Aggregator::Object->new(
        methods => [qw( foo bar something something_else )],
        class   => 'MyClass',
        title   => 'mytitle',
        url     => 'myurl',
        modtime => 'mylastmod'
        indexer => SWISH::Prog::Indexer::Native->new,
    );

    my $data = my_func_for_fetching_data();
    # $data is either iterator or arrayref of objects

    $aggregator->indexer->start;
    $aggregator->crawl( $data );
    $aggregator->indexer->finish;

 while( my $object = $data->next )
 {
     $aggregator->method_to_index( $object );
 }

    perldoc SWISH::Prog

package SWISH::Prog::Aggregator::Object;

use strict;
use warnings;
use base qw( SWISH::Prog::Aggregator );

use Carp;
use YAML::Syck ();
use JSON       ();
use SWISH::Prog::Utils;
use Scalar::Util qw( blessed );

__PACKAGE__->mk_accessors(
    qw( methods class title url modtime serial_format ));

our $VERSION = '0.51';

my $XMLer = Search::Tools::XML->new();    # included in Utils

sub init {
    my $self = shift;
    $self->SUPER::init(@_);

    $self->{title}         ||= 'title';
    $self->{url}           ||= 'url';
    $self->{modtime}       ||= 'modtime';
    $self->{serial_format} ||= 'json';

    unless ( $self->{methods} ) {
        croak "methods required";
    }

    # set up the config object
    my $config = $self->{indexer}->{config};

    ( my $class_meta = $self->class ) =~ s/\W/\./g;
    $self->{_class_meta} = $class_meta;

    # make urls find-able (really should adjust WordCharacters too...)
    $config->MaxWordLimit(256) unless $config->MaxWordLimit;

    # similar to DBI, we alias top-level tag
    # so all words are find-able via swishdefault
    $config->MetaNameAlias( 'swishdefault ' . $class_meta )
        unless $config->MetaNameAlias;
    $config->MetaNames( @{ $self->methods } ) unless @{ $config->MetaNames };

    $config->PropertyNames( @{ $self->methods } )
        unless @{ $config->PropertyNames };

    # IMPORTANT to do this because whitespace matters in YAML
    # NOTE that due to swish-e cache buffering, YAML fields
    # that are longer than 10k can get seriously messed up.
    # this is a swish-e bug that should be fixed.
    $config->PropertyNamesNoStripChars( @{ $self->methods } )
        unless @{ $config->PropertyNamesNoStripChars };

    $config->IndexDescription(
        join(
            ' ', 'class:' . $self->class, 'format:' . $self->serial_format
        )
    ) unless $config->IndexDescription;

}

sub crawl {
    my $self    = shift;
    my $data    = shift;
    my $indexer = $self->indexer;

    # IMPORTANT! that this not be undef since url defaults to it.
    $self->{count} = 0;

    if ( ref($data) eq 'ARRAY' ) {

        $self->{class} ||= blessed( $data->[0] );
        for my $o (@$data) {
            $indexer->process( $self->get_doc($o) );
            $self->_increment_count;
        }

    }
    elsif ( ref($data) && $data->can('next') ) {
        my $first = $data->next;
        $self->{class} ||= blessed($first);
        $indexer->process( $self->get_doc($first) );

        while ( my $o = $data->next ) {
            $indexer->process( $self->get_doc($o) );
            $self->_increment_count;
        }
    }
    else {
        croak "\$data $data doesn't look like it's in the expected format";
    }

    return $self->{count};
}

sub get_doc {
    my $self = shift;
    my $object = shift or croak "need object";

    my $titlemeth   = $self->{title};
    my $urlmeth     = $self->{url};
    my $modtimemeth = $self->{modtime};

    my $title
        = $object->can($titlemeth) ? $object->$titlemeth : '[ no title ]';

    my $url
        = $object->can($urlmeth)
        ? $object->$urlmeth
        : $self->{count};

    my $modtime
        = $object->can($modtimemeth)
        ? $object->$modtimemeth
        : time();

    my $xml = $self->_obj2xml( $self->{_class_meta}, $object, $title );

    my $doc = $self->doc_class->new(
        content => $xml,
        url     => $url,
        modtime => $modtime,
        parser  => 'XML*',
        type    => 'application/x-object',
        data    => $object
    );

    $self->debug and print $doc;

    return $doc;
}

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

    my $xml
        = $XMLer->start_tag($class)
        . "<swishtitle>"
        . $XMLer->utf8_safe($title)
        . "</swishtitle>";

    for my $m ( @{ $self->methods } ) {
        my $v = $self->serialize( $o, $m );

        my @x = (
            $XMLer->start_tag($m), $XMLer->utf8_safe($v), $XMLer->end_tag($m)
        );

        $xml .= join( '', @x );
    }
    $xml .= $XMLer->end_tag($class);

    $self->debug and print STDOUT $xml . "\n";

    return $xml;
}

sub serialize {
    my $self = shift;
    my ( $o, $m ) = @_;
    my $v = $o->$m;
    unless ( ref $v ) {
        return $v;
    }
    else {
        if ( $self->serial_format eq 'json' ) {
            return JSON->new->convert_blessed(1)->allow_blessed(1)
                ->encode($v);
        }
        elsif ( $self->serial_format eq 'yaml' ) {
            return YAML::Syck::Dump($v);
        }
        else {
            croak "unknown serial_format: " . $self->serial_format;
        }
    }

}

1;

__END__