source: trunk/gsdl/perllib/classify/AZCompactSectionList.pm@ 8728

###########################################################################
#
# AZCompactSectionList.pm --
#
# Experimental AZCompactList with fixes to handle section-level metadata
#
###########################################################################

package AZCompactSectionList;

use AZCompactList;

sub BEGIN {
    @ISA = ('AZCompactList');
}

my $options = 
{   'name'     => "AZCompactSectionList",
    'desc'     => "{AZCompactSectionList.desc}",
    'abstract' => "no",
    'inherits' => "yes",
    'args'     => $arguments };

sub new {
    my $class = shift (@_);
    my $self = new AZCompactList($class, @_);

    # 14-05-02 To allow for proper inheritance of arguments - John Thompson
    my $option_list = $self->{'option_list'};
    push( @{$option_list}, $options );

    #if ($self->{'info_only'}) {
    # created from classinfo.pl - don't need to parse the arguments
    #return bless $self, $class;
    #}

    return bless $self, $class;
}

#
# override reinit() & reclassify() to demonstrate possible bug fixes
# (search for SECTIONFIX? to see lines changed from AZCompactList.pm)
#
sub reinit 
{
    my ($self,$classlist_ref) = @_;
    
    my %mtfreq = ();
    my @single_classlist = ();
    my @multiple_classlist = ();

    # find out how often each metavalue occurs
    map 
    { 
    my $mv;
    foreach $mv (@{$self->{'listmetavalue'}->{$_}} )
    {
        $mtfreq{$mv}++; 
    }
    } @$classlist_ref;

    # use this information to split the list: single metavalue/repeated value
    map
    { 
    my $i = 1;
    my $metavalue;
    foreach $metavalue (@{$self->{'listmetavalue'}->{$_}})
    {
        if ($mtfreq{$metavalue} >= $self->{'mingroup'})
        {
        push(@multiple_classlist,[$_,$i,$metavalue]); 
        } 
        else
        {
        push(@single_classlist,[$_,$metavalue]); 
        $metavalue =~ tr/[A-Z]/[a-z]/;
        $self->{'reclassifylist'}->{"Metavalue_$i.$_"} = $metavalue;
        }
        $i++;
    }
    } @$classlist_ref;
    
    
    # Setup sub-classifiers for multiple list

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

    my $pm;
    foreach $pm ("List", "SectionList")
    {
    my $listname 
        = &util::filename_cat($ENV{'GSDLHOME'},"perllib/classify/$pm.pm");
    if (-e $listname) { require $listname; }
    else 
    { 
        my $outhandle = $self->{'outhandle'};
        print $outhandle "AZCompactList ERROR - couldn't find classifier \"$listname\"\n"; 
        die "\n";
    }
    }

    # Create classifiers objects for each entry >= mingroup
    my $metavalue;
    foreach $metavalue (keys %mtfreq)
    {
    if ($mtfreq{$metavalue} >= $self->{'mingroup'})
    {
        my $listclassobj;
        my $doclevel = $self->{'doclevel'};
        my $metaname  = $self->{'metaname'};
        my @metaname_list = split('/',$metaname);
        $metaname = shift(@metaname_list);
        if (@metaname_list==0)
        {
        my @args;
        push @args, ("-metadata", "$metaname");
# buttonname is also used for the node's title
        push @args, ("-buttonname", "$metavalue");
        push @args, ("-sort", "Date");

        if ($doclevel =~ m/^top(level)?/i)
        {
            eval ("\$listclassobj = new List(\@args)"); warn $@ if $@;
        }
        else
        {
            # SECTIONFIX?
            #eval ("\$listclassobj = new SectionList($args)");
            eval ("\$listclassobj = new SectionList(\@args)");
        }
        }
        else
        {
        $metaname = join('/',@metaname_list);
        
        my @args;
        push @args, ("-metadata", "$metaname");
# buttonname is also used for the node's title
        push @args, ("-buttonname", "$metavalue");
        push @args, ("-doclevel", "$doclevel");
        push @args, "-recopt";

        # SECTIONFIX?
        #eval ("\$listclassobj = new AZCompactList($args)");
        eval ("\$listclassobj = new AZCompactList(\@args)");
        }
        if ($@) {
        my $outhandle = $self->{'outhandle'};
        print $outhandle "$@";
        die "\n";
        }
        
        $listclassobj->init();

        if (defined $metavalue && $metavalue =~ /\w/) 
        {
        my $formatted_node = $metavalue;
        if ($self->{'metaname'} =~ m/^Creator(:.*)?$/)
        {
            &sorttools::format_string_name_english(\$formatted_node);
        } 
        else 
        {
            &sorttools::format_string_english(\$formatted_node);
        }
        
        $self->{'classifiers'}->{$metavalue} 
        = { 'classifyobj'   => $listclassobj,
            'formattednode' => $formatted_node };
        }
    }
    }


    return (\@single_classlist,\@multiple_classlist);
}


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

    # Entries in the current classify list that are "book nodes"
    # should be recursively classified.
    #--
    foreach $dm_pair (@$multiple_cl_ref) 
    {
    my ($doc_OID,$mdoffset,$metavalue) = @$dm_pair;
        my $listclassobj;

    # find metavalue in list of sub-classifiers
    my $found = 0;
    my $node_name;
    foreach $node_name (keys %{$self->{'classifiers'}}) 
    {
        $resafe_node_name = $node_name;
        $resafe_node_name =~ s/(\(|\)|\[|\]|\{|\}|\^|\$|\.|\+|\*|\?|\|)/\\$1/g;
        if ($metavalue =~ m/^$resafe_node_name$/i) 
        {
        my ($doc_obj,$date) = @{$self->{'reclassify'}->{$doc_OID}};

        ## date appears to not be used in classifier call ####

        # SECTIONFIX?  section must include multiple levels, e.g. '1.12'
        #if ($doc_OID =~ m/^.*\.(\d+)$/)
        if ($doc_OID =~ m/^[^\.]*\.([\d\.]+)$/)
        {
            $self->{'classifiers'}->{$node_name}->{'classifyobj'}
            # SECTIONFIX? classify can't handle multi-level section
            #->classify($doc_obj, "Section=$1"); 
            ->classify_section($1, $doc_obj, $date);
        }
        else
        {
            $self->{'classifiers'}->{$node_name}->{'classifyobj'}
            ->classify($doc_obj); 
        }
        
        $found = 1;
        last;
        }
    }
    
    if (!$found)
    {
        print $outhandle "Warning: AZCompactList::reclassify ";
        print $outhandle "could not find sub-node for $metavalue with doc_OID $doc_OID\n";
    }
    }
}

1;