jsFind/trunk/jsFind.pm

package jsFind;

use 5.005;
use strict;
use warnings;
use HTML::Entities;

our $VERSION = '0.03';

use Exporter 'import';
use Carp;

our @ISA = qw(Exporter);

BEGIN {
        import 'jsFind::Node';
}

=head1 NAME

jsFind - generate index for jsFind using B-Tree

=head1 SYNOPSIS

  use jsFind;
  my $t = new jsFind(B => 4);
  my $f = 1;
  foreach my $k (qw{minima ut dolorem sapiente voluptatem}) {
        $t->B_search(Key => $k,
                Data => {
                        "path" => {
                        t => "word $k",
                        f => $f },
                },
                Insert => 1,
                Append => 1,
        );
  }

=head1 DESCRIPTION

This module can be used to create index files for jsFind, powerful tool for
adding a search engine to a CDROM archive or catalog without requiring the
user to install anything. 

Main difference between this module and scripts delivered with jsFind are:

=over 5

=item *

You don't need to use swish-e to create index

=item *

You can programatically (and incrementaly) create index for jsFind

=back

You can also examine examples which come as tests with this module,
for example C<t/04words.t>.

=head1 jsFind methods

C<jsFind> is mode implementing methods which you, the user, are going to
use to create indexes.

=head2 new

Create new tree. Arguments are C<B> which is maximum numbers of keys in
each node and optional C<Root> node. Each root node may have child nodes.

All nodes are objects from C<jsFind::Node>.

 my $t = new jsFind(B => 4);

=cut

my $DEBUG = 1;

sub new {
  my $package = shift;
  my %ARGV = @_;
  croak "Usage: {$package}::new(B => number [, Root => root node ])"
      unless exists $ARGV{B};
  if ($ARGV{B} % 2) {
    my $B = $ARGV{B} + 1;
    carp "B must be an even number.  Using $B instead.";
    $ARGV{B} = $B;
  }
    
  my $B = $ARGV{B};
  my $Root = exists($ARGV{Root}) ? $ARGV{Root} : jsFind::Node->emptynode;
  bless { B => $B, Root => $Root } => $package;
}

=head2 B_search

Search, insert, append or replace data in B-Tree

 $t->B_search(
        Key => 'key value',
        Data => { "path" => {
                        "t" => "title of document",
                        "f" => 99,
                        },
                },
        Insert => 1,
        Append => 1,
 );

Semantics:

If key not found, insert it iff C<Insert> argument is present.

If key B<is> found, replace existing data iff C<Replace> argument
is present or add new datum to existing iff C<Append> argument is present.

=cut

sub B_search {
  my $self = shift;
  my %args = @_;
  my $cur_node = $self->root;
  my $k = $args{Key};
  my $d = $args{Data};
  my @path;

  if ($cur_node->is_empty) {    # Special case for empty root
    if ($args{Insert}) {
      $cur_node->kdp_insert($k => $d);
      return $d;
    } else {
      return undef;
    }
  }

  # Descend tree to leaf
  for (;;) {

    # Didn't hit bottom yet.

    my($there, $where) = $cur_node->locate_key($k);
    if ($there) {               # Found it!
      if ($args{Replace}) {
        $cur_node->kdp_replace($where, $k => $d);
      } elsif ($args{Append}) {
        $cur_node->kdp_append($where, $k => $d);
      }
      return $cur_node->data($where);
    }
    
    # Not here---must be in a subtree.
    
    if ($cur_node->is_leaf) {   # But there are no subtrees
      return undef unless $args{Insert}; # Search failed
      # Stuff it in
      $cur_node->kdp_insert($k => $d);
      if ($self->node_overfull($cur_node)) { # Oops--there was no room.
        $self->split_and_promote($cur_node, @path);
      } 
      return $d;
    }

    # There are subtrees, and the key is in one of them.

    push @path, [$cur_node, $where];    # Record path from root.

    # Move down to search the subtree
    $cur_node = $cur_node->subnode($where);

    # and start over.
  }                             # for (;;) ...

  croak ("How did I get here?");
}


sub split_and_promote_old {
  my $self = shift;
  my ($cur_node, @path) = @_;
  
  for (;;) {
    my ($newleft, $newright, $kdp) = $cur_node->halves($self->B / 2);
    my ($up, $where) = @{pop @path};
    if ($up) {
      $up->kdp_insert(@$kdp);
      my ($tthere, $twhere) = $up->locate_key($kdp->[0]);
      croak "Couldn't find key `$kdp->[0]' in node after just inserting it!"
          unless $tthere;
      croak "`$kdp->[0]' went into node at `$twhere' instead of expected `$where'!"
          unless $twhere == $where;
      $up->subnode($where,   $newleft);
      $up->subnode($where+1, $newright);
      return unless $self->node_overfull($up);
      $cur_node = $up;
    } else { # We're at the top; make a new root.
      my $newroot = new jsFind::Node ([$kdp->[0]], 
                                     [$kdp->[1]], 
                                     [$newleft, $newright]);
      $self->root($newroot);
      return;
    }
  }
  
}

sub split_and_promote {
  my $self = shift;
  my ($cur_node, @path) = @_;
  
  for (;;) {
    my ($newleft, $newright, $kdp) = $cur_node->halves($self->B / 2);
    my ($up, $where) = @{pop @path} if (@path);
    if ($up) {
      $up->kdp_insert(@$kdp);
      if ($DEBUG) {
        my ($tthere, $twhere) = $up->locate_key($kdp->[0]);
        croak "Couldn't find key `$kdp->[0]' in node after just inserting it!"
          unless $tthere;
        croak "`$kdp->[0]' went into node at `$twhere' instead of expected `$where'!"
          unless $twhere == $where;
      }
      $up->subnode($where,   $newleft);
      $up->subnode($where+1, $newright);
      return unless $self->node_overfull($up);
      $cur_node = $up;
    } else { # We're at the top; make a new root.
      my $newroot = new jsFind::Node([$kdp->[0]], 
                                     [$kdp->[1]], 
                                     [$newleft, $newright]);
      $self->root($newroot);
      return;
    }
  }
}

=head2 B

Return B (maximum number of keys)

 my $max_size = $t->B;

=cut

sub B {
  $_[0]{B};
}

=head2 root

Returns root node

 my $root = $t->root;

=cut

sub root {
  my ($self, $newroot) = @_;
  $self->{Root} = $newroot if defined $newroot;
  $self->{Root};
}

=head2 node_overfull

Returns if node is overfull

 if ($node->node_overfull) { something }

=cut

sub node_overfull {
  my $self = shift;
  my $node = shift;
  $node->size > $self->B;
}

=head2 to_string

Returns your tree as formatted string.

 my $text = $root->to_string;

Mostly usefull for debugging as output leaves much to be desired.

=cut

sub to_string {
  $_[0]->root->to_string;
}

=head2 to_dot

Create Graphviz graph of your tree

 my $dot_graph = $root->to_dot;

=cut

sub to_dot {
        my $self = shift;

        my $dot = qq/digraph dns {\nrankdir=LR;\n/;
        $dot .= $self->root->to_dot;
        $dot .= qq/\n}\n/;

        return $dot;
}

=head2 to_jsfind

Create xml index files for jsFind. This should be called after
your B-Tree has been filled with data.

 $root->to_jsfind('/full/path/to/index/dir/');

Returns number of nodes in created tree.

There is also longer version if you want to recode your data charset
into different one (probably UTF-8):

 $root->to_jsfind('/full/path/to/index/dir/','ISO-8859-2','UTF-8');

Destination encoding is UTF-8 by default, so you don't have to specify it.

 $root->to_jsfind('/full/path/to/index/dir/','WINDOWS-1250');

=cut

my $iconv;
my $iconv_l1;

sub to_jsfind {
        my $self = shift;

        my $path = shift || confess "to_jsfind need path to your index!";

        my ($from_cp,$to_cp) = @_;

        $to_cp ||= 'UTF-8';

        if ($from_cp && $to_cp) {
                $iconv = Text::Iconv->new($from_cp,$to_cp);
        }
        $iconv_l1 = Text::Iconv->new('ISO-8859-1',$to_cp);

        $path .= "/" if ($path =~ /\/$/);
        #carp "creating directory for index '$path'" if (! -w $path);

        return $self->root->to_jsfind($path,"0");
}


# private, default cmd function
sub default_cmp {
  $_[0] cmp $_[1];
}

=head2 _recode

This is internal function to recode charset.

It will also try to decode entities in data using L<HTML::Entities>.

=cut

sub _recode {
        my $self = shift;
        my $text = shift || return;

        sub _decode_html_entities {
                my $data = shift || return;
                $data = $iconv_l1->convert(decode_entities($data)) || croak "entity decode problem: $data";
        }

        if ($iconv) {
                $text = $iconv->convert($text) || $text && carp "convert problem: $text";
                $text =~ s/(\&\w+;)/_decode_html_entities($1)/ges;
        }

        return $text;
}

#####################################################################

=head1 jsFind::Node methods

Each node has C<k> key-data pairs, with C<B> <= C<k> <= C<2B>, and 
each has C<k+1> subnodes, which might be null.

The node is a blessed reference to a list with three elements:

  ($keylist, $datalist, $subnodelist)

each is a reference to a list list.

The null node is represented by a blessed reference to an empty list.

=cut

package jsFind::Node;

use warnings;
use strict;

use Carp;
use File::Path;
use Text::Iconv;

use base 'jsFind';

my $KEYS = 0;
my $DATA = 1;
my $SUBNODES = 2;

=head2 new

Create New node

 my $node = new jsFind::Node ($keylist, $datalist, $subnodelist);

You can also mit argument list to create empty node.

 my $empty_node = new jsFind::Node;

=cut

sub new {
  my $self = shift;
  my $package = ref $self || $self;
  croak "Internal error:  jsFind::Node::new called with wrong number of arguments."
      unless @_ == 3 || @_ == 0;
  bless [@_] => $package;
}

=head2 locate_key

Locate key in node using linear search. This should probably be replaced
by binary search for better performance.

 my ($found, $index) = $node->locate_key($key, $cmp_coderef);

Argument C<$cmp_coderef> is optional reference to custom comparison
operator.

Returns (1, $index) if $key[$index] eq $key.

Returns (0, $index) if key could be found in $subnode[$index].

In scalar context, just returns 1 or 0.

=cut

sub locate_key {
  # Use linear search for testing, replace with binary search.
  my $self = shift;
  my $key = shift;
  my $cmp = shift || \&jsFind::default_cmp;
  my $i;
  my $cmp_result;
  my $N = $self->size;
  for ($i = 0; $i < $N; $i++) {
    $cmp_result = &$cmp($key, $self->key($i));
    last if $cmp_result <= 0;
  }
  
  # $i is now the index of the first node-key greater than $key
  # or $N if there is no such.  $cmp_result is 0 iff the key was found.
  (!$cmp_result, $i);
}


=head2 emptynode

Creates new empty node

 $node = $root->emptynode;
 $new_node = $node->emptynode;

=cut

sub emptynode {
  new($_[0]);                   # Pass package name, but not anything else.
}

=head2 is_empty

Test if node is empty

 if ($node->is_empty) { something }

=cut

# undef is empty; so is a blessed empty list.
sub is_empty {
  my $self = shift;
  !defined($self) || $#$self < 0;
}

=head2 key

Return C<$i>th key from node

 my $key = $node->key($i);

=cut

sub key {
#  my ($self, $n) = @_;
#  $self->[$KEYS][$n];

#       speedup
   $_[0]->[$KEYS][$_[1]];
}

=head2 data

Return C<$i>th data from node

 my $data = $node->data($i);

=cut

sub data {
  my ($self, $n) = @_;
  $self->[$DATA][$n];
}

=head2 kdp_replace

Set key data pair for C<$i>th element in node

 $node->kdp_replace($i, "key value" => {
        "data key 1" => "data value 1",
        "data key 2" => "data value 2",
 };

=cut

sub kdp_replace {
  my ($self, $n, $k => $d) = @_;
  if (defined $k) {
    $self->[$KEYS][$n] = $k;
    $self->[$DATA][$n] = $d;
  }
  [$self->[$KEYS][$n], 
   $self->[$DATA][$n]];
}

=head2 kdp_insert

Insert key/data pair in tree

  $node->kdp_insert("key value" => "data value");

No return value.

=cut

sub kdp_insert {
  my $self = shift;
  my ($k => $d) = @_;
  my ($there, $where) = $self->locate_key($k) unless $self->is_empty;

  if ($there) { croak("Tried to insert `$k => $d' into node where `$k' was already present."); }

  # undef fix
  $where ||= 0;

  splice(@{$self->[$KEYS]}, $where, 0, $k);
  splice(@{$self->[$DATA]}, $where, 0, $d);
  splice(@{$self->[$SUBNODES]}, $where, 0, undef);
}

=head2 kdp_append

Adds new data keys and values to C<$i>th element in node

 $node->kdp_append($i, "key value" => {
        "added data key" => "added data value",
 };

=cut

sub kdp_append {
  my ($self, $n, $k => $d) = @_;
  if (defined $k) {
    $self->[$KEYS][$n] = $k;
    my ($kv,$dv) = %{$d};
    $self->[$DATA][$n]->{$kv} = $dv;
  }
  [$self->[$KEYS][$n], 
   $self->[$DATA][$n]];
}

=head2 subnode

Set new or return existing subnode

 # return 4th subnode
 my $my_node = $node->subnode(4);

 # create new subnode 5 from $my_node
 $node->subnode(5, $my_node);

=cut

sub subnode {
  my ($self, $n, $newnode) = @_;
  $self->[$SUBNODES][$n] = $newnode if defined $newnode;
  $self->[$SUBNODES][$n];
}

=head2 is_leaf

Test if node is leaf

 if ($node->is_leaf) { something }

=cut

sub is_leaf {
  my $self = shift;
  ! defined $self->[$SUBNODES][0]; # undefined subnode means leaf node.
}

=head2 size

Return number of keys in the node

 my $nr = $node->size;

=cut

sub size {
  my $self = shift;
  return scalar(@{$self->[$KEYS]});
}

=head2 halves

Split node into two halves so that keys C<0 .. $n-1> are in one node
and keys C<$n+1 ... $size> are in the other.

  my ($left_node, $right_node, $kdp) = $node->halves($n);

=cut

sub halves {
  my $self = shift;
  my $n = shift;
  my $s = $self->size;
  my @right;
  my @left;

  $left[$KEYS] = [@{$self->[$KEYS]}[0 .. $n-1]];
  $left[$DATA] = [@{$self->[$DATA]}[0 .. $n-1]];
  $left[$SUBNODES] = [@{$self->[$SUBNODES]}[0 .. $n]];

  $right[$KEYS] = [@{$self->[$KEYS]}[$n+1 .. $s-1]];
  $right[$DATA] = [@{$self->[$DATA]}[$n+1 .. $s-1]];
  $right[$SUBNODES] = [@{$self->[$SUBNODES]}[$n+1 .. $s]];

  my @middle = ($self->[$KEYS][$n], $self->[$DATA][$n]);

  ($self->new(@left), $self->new(@right), \@middle);
}

=head2 to_string

Dumps tree as string

 my $str = $root->to_string;

=cut

sub to_string {
  my $self = shift;
  my $indent = shift || 0;
  my $I = ' ' x $indent;
  return '' if $self->is_empty;
  my ($k, $d, $s) = @$self;
  my $result = '';
  $result .= defined($s->[0]) ? $s->[0]->to_string($indent+2) : '';
  my $N = $self->size;
  my $i;
  for ($i = 0; $i < $N; $i++) {
#    $result .= $I . "$k->[$i] => $d->[$i]\n";
    $result .= $I . "$k->[$i]\n";
    $result .= defined($s->[$i+1]) ? $s->[$i+1]->to_string($indent+2) : '';
  }
  $result;
}

=begin comment

use Data::Dumper;

sub to_string {
  my $self = shift;
  my $indent = shift || 0;
  my $path = shift || '0';
  return '' if $self->is_empty;
  my ($k, $d, $s) = @$self;
  my $result = '';
  $result .= defined($s->[0]) ? $s->[0]->to_string($indent+1,"$path/0") : '';
  my $N = $self->size;
  for (my $i = 0; $i < $N; $i++) {
        my $dump = Dumper($d->[$i]);
        $dump =~ s/[\n\r\s]+/ /gs;
        $dump =~ s/\$VAR1\s*=\s*//;
    $result .= sprintf("%-5s [%2d] %2s: %s => %s\n", $path, $i, $indent, $k->[$i], $dump);
    $result .= defined($s->[$i+1]) ? $s->[$i+1]->to_string($indent+1,"$path/$i") : '';
  }
  $result;
}

=end comment

=head2 to_dot

Recursivly walk nodes of tree

=cut

sub to_dot {
        my $self = shift;
        my $parent = shift;

        return '' if $self->is_empty;

        my $dot = '';

        my ($k, $d, $s) = @$self;
        my $N = $self->size;

        my @dot_keys;

        my $node_name = $parent || '_';
        $node_name =~ s/\W+//g;
        $node_name .= " [$N]";

        for (my $i = 0; $i <= $N; $i++) {
                if (my $key = $k->[$i]) {
                        push @dot_keys, qq{<$i>$key};
                }
                $dot .= $s->[$i]->to_dot(qq{"$node_name":$i}) if ($s->[$i]);
        }
        push @dot_keys, qq{<$N>...} if (! $self->is_leaf);

        my $label = join("|",@dot_keys);
        $dot .= qq{"$node_name" [ shape=record, label="$label" ];\n};

        $dot .= qq{$parent -> "$node_name";\n} if ($parent);

        $dot;
}

=head2 to_xml

Escape <, >, & and ", and to produce valid XML

=cut

my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
my $escape_re  = join '|' => keys %escape;

sub to_xml {
        my $self = shift || confess "you should call to_xml as object!";

        my $d = shift || return;
        $d = $self->SUPER::_recode($d);
        confess "escape_re undefined!" unless ($escape_re);
        $d =~ s/($escape_re)/$escape{$1}/g;
        return $d;
}

=head2 to_jsfind

Create jsFind xml files

 my $nr=$tree->to_jsfind('/path/to/index','0');

Returns number of elements created

=cut


sub to_jsfind {
        my $self = shift;
        my ($path,$file) = @_;

        return 0 if $self->is_empty;

        confess("path is undefined.") unless ($path);
        confess("file is undefined. Did you call \$t->root->to_jsfind(..) instead of \$t->to_jsfind(..) ?") unless (defined($file));

        my $nr_keys = 0;

        my ($k, $d, $s) = @$self;
        my $N = $self->size;

        my ($key_xml, $data_xml) = ("<n>","<d>");

        for (my $i = 0; $i <= $N; $i++) {
                my $key = lc($k->[$i]);

                if ($key) {
                        $key_xml .= '<k>'.$self->to_xml($key).'</k>';
                        $data_xml .= '<e>';
        #use Data::Dumper;
        #print Dumper($d->[$i]);
                        foreach my $path (keys %{$d->[$i]}) {
                                $data_xml .= '<l f="'.($d->[$i]->{$path}->{'f'} || 1).'" t="'.$self->to_xml($d->[$i]->{$path}->{'t'} || 'no title').'">'.$self->to_xml($path).'</l>';
                                $nr_keys++;
                        }
                        $data_xml .= '</e>';
                }

                $nr_keys += $s->[$i]->to_jsfind("$path/$file","$i") if ($s->[$i]);
        }

        $key_xml .= '</n>';
        $data_xml .= '</d>';

        if (! -e $path) {
                mkpath($path) || croak "can't create dir '$path': $!";
        }

        open(K, "> ${path}/${file}.xml") || croak "can't open '$path/$file.xml': $!";
        open(D, "> ${path}/_${file}.xml") || croak "can't open '$path/_$file.xml': $!";

        print K $key_xml;
        print D $data_xml;

        close(K);
        close(D);

        return $nr_keys;
}

1;
__END__

=head1 SEE ALSO

jsFind web site L<http://www.elucidsoft.net/projects/jsfind/>

B-Trees in perl web site L<http://perl.plover.com/BTree/>

This module web site L<http://www.rot13.org/~dpavlin/jsFind.html>

=head1 AUTHORS

Mark-Jonson Dominus E<lt>mjd@pobox.comE<gt> wrote C<BTree.pm> which was
base for this module

Shawn P. Garbett E<lt>shawn@elucidsoft.netE<gt> wrote jsFind

Dobrica Pavlinusic E<lt>dpavlin@rot13.orgE<gt> wrote this module

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2004 by Dobrica Pavlinusic

This program 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.

=cut
1	dpavlin	1	package jsFind;
2
3	dpavlin	14	use 5.005;
4	dpavlin	1	use strict;
5			use warnings;
6	dpavlin	11	use HTML::Entities;
7	dpavlin	1
8	dpavlin	11	our $VERSION = '0.03';
9	dpavlin	1
10	dpavlin	12	use Exporter 'import';
11			use Carp;
12
13			our @ISA = qw(Exporter);
14
15			BEGIN {
16			import 'jsFind::Node';
17			}
18
19	dpavlin	1	=head1 NAME
20
21			jsFind - generate index for jsFind using B-Tree
22
23			=head1 SYNOPSIS
24
25			use jsFind;
26	dpavlin	12	my $t = new jsFind(B => 4);
27			my $f = 1;
28			foreach my $k (qw{minima ut dolorem sapiente voluptatem}) {
29			$t->B_search(Key => $k,
30			Data => {
31			"path" => {
32			t => "word $k",
33			f => $f },
34			},
35			Insert => 1,
36			Append => 1,
37			);
38			}
39	dpavlin	1
40			=head1 DESCRIPTION
41
42			This module can be used to create index files for jsFind, powerful tool for
43			adding a search engine to a CDROM archive or catalog without requiring the
44			user to install anything.
45
46			Main difference between this module and scripts delivered with jsFind are:
47
48			=over 5
49
50			=item *
51
52			You don't need to use swish-e to create index
53
54			=item *
55
56			You can programatically (and incrementaly) create index for jsFind
57
58			=back
59
60	dpavlin	14	You can also examine examples which come as tests with this module,
61			for example C<t/04words.t>.
62
63	dpavlin	12	=head1 jsFind methods
64	dpavlin	1
65	dpavlin	12	C<jsFind> is mode implementing methods which you, the user, are going to
66			use to create indexes.
67	dpavlin	1
68	dpavlin	12	=head2 new
69	dpavlin	1
70			Create new tree. Arguments are C<B> which is maximum numbers of keys in
71			each node and optional C<Root> node. Each root node may have child nodes.
72
73			All nodes are objects from C<jsFind::Node>.
74
75			my $t = new jsFind(B => 4);
76
77			=cut
78
79			my $DEBUG = 1;
80
81			sub new {
82			my $package = shift;
83			my %ARGV = @_;
84			croak "Usage: {$package}::new(B => number [, Root => root node ])"
85			unless exists $ARGV{B};
86			if ($ARGV{B} % 2) {
87			my $B = $ARGV{B} + 1;
88			carp "B must be an even number. Using $B instead.";
89			$ARGV{B} = $B;
90			}
91
92			my $B = $ARGV{B};
93			my $Root = exists($ARGV{Root}) ? $ARGV{Root} : jsFind::Node->emptynode;
94			bless { B => $B, Root => $Root } => $package;
95			}
96
97	dpavlin	12	=head2 B_search
98	dpavlin	1
99			Search, insert, append or replace data in B-Tree
100
101	dpavlin	5	$t->B_search(
102			Key => 'key value',
103			Data => { "path" => {
104			"t" => "title of document",
105			"f" => 99,
106	dpavlin	7	},
107	dpavlin	5	},
108			Insert => 1,
109			Append => 1,
110			);
111	dpavlin	1
112			Semantics:
113
114			If key not found, insert it iff C<Insert> argument is present.
115
116			If key B<is> found, replace existing data iff C<Replace> argument
117			is present or add new datum to existing iff C<Append> argument is present.
118
119			=cut
120
121			sub B_search {
122			my $self = shift;
123			my %args = @_;
124			my $cur_node = $self->root;
125			my $k = $args{Key};
126			my $d = $args{Data};
127			my @path;
128
129			if ($cur_node->is_empty) { # Special case for empty root
130			if ($args{Insert}) {
131			$cur_node->kdp_insert($k => $d);
132			return $d;
133			} else {
134			return undef;
135			}
136			}
137
138			# Descend tree to leaf
139			for (;;) {
140
141			# Didn't hit bottom yet.
142
143			my($there, $where) = $cur_node->locate_key($k);
144			if ($there) { # Found it!
145			if ($args{Replace}) {
146			$cur_node->kdp_replace($where, $k => $d);
147			} elsif ($args{Append}) {
148			$cur_node->kdp_append($where, $k => $d);
149			}
150			return $cur_node->data($where);
151			}
152
153			# Not here---must be in a subtree.
154
155			if ($cur_node->is_leaf) { # But there are no subtrees
156			return undef unless $args{Insert}; # Search failed
157			# Stuff it in
158			$cur_node->kdp_insert($k => $d);
159			if ($self->node_overfull($cur_node)) { # Oops--there was no room.
160			$self->split_and_promote($cur_node, @path);
161			}
162			return $d;
163			}
164
165			# There are subtrees, and the key is in one of them.
166
167			push @path, [$cur_node, $where]; # Record path from root.
168
169			# Move down to search the subtree
170			$cur_node = $cur_node->subnode($where);
171
172			# and start over.
173			} # for (;;) ...
174
175			croak ("How did I get here?");
176			}
177
178
179
180			sub split_and_promote_old {
181			my $self = shift;
182			my ($cur_node, @path) = @_;
183
184			for (;;) {
185			my ($newleft, $newright, $kdp) = $cur_node->halves($self->B / 2);
186			my ($up, $where) = @{pop @path};
187			if ($up) {
188			$up->kdp_insert(@$kdp);
189			my ($tthere, $twhere) = $up->locate_key($kdp->[0]);
190			croak "Couldn't find key `$kdp->[0]' in node after just inserting it!"
191			unless $tthere;
192			croak "`$kdp->[0]' went into node at `$twhere' instead of expected `$where'!"
193			unless $twhere == $where;
194			$up->subnode($where, $newleft);
195			$up->subnode($where+1, $newright);
196			return unless $self->node_overfull($up);
197			$cur_node = $up;
198			} else { # We're at the top; make a new root.
199			my $newroot = new jsFind::Node ([$kdp->[0]],
200			[$kdp->[1]],
201			[$newleft, $newright]);
202			$self->root($newroot);
203			return;
204			}
205			}
206
207			}
208
209			sub split_and_promote {
210			my $self = shift;
211			my ($cur_node, @path) = @_;
212
213			for (;;) {
214			my ($newleft, $newright, $kdp) = $cur_node->halves($self->B / 2);
215			my ($up, $where) = @{pop @path} if (@path);
216			if ($up) {
217			$up->kdp_insert(@$kdp);
218			if ($DEBUG) {
219			my ($tthere, $twhere) = $up->locate_key($kdp->[0]);
220			croak "Couldn't find key `$kdp->[0]' in node after just inserting it!"
221			unless $tthere;
222			croak "`$kdp->[0]' went into node at `$twhere' instead of expected `$where'!"
223			unless $twhere == $where;
224			}
225			$up->subnode($where, $newleft);
226			$up->subnode($where+1, $newright);
227			return unless $self->node_overfull($up);
228			$cur_node = $up;
229			} else { # We're at the top; make a new root.
230			my $newroot = new jsFind::Node([$kdp->[0]],
231			[$kdp->[1]],
232			[$newleft, $newright]);
233			$self->root($newroot);
234			return;
235			}
236			}
237			}
238
239	dpavlin	12	=head2 B
240	dpavlin	1
241			Return B (maximum number of keys)
242
243			my $max_size = $t->B;
244
245			=cut
246
247			sub B {
248			$_[0]{B};
249			}
250
251	dpavlin	12	=head2 root
252	dpavlin	1
253			Returns root node
254
255			my $root = $t->root;
256
257			=cut
258
259			sub root {
260			my ($self, $newroot) = @_;
261			$self->{Root} = $newroot if defined $newroot;
262			$self->{Root};
263			}
264
265	dpavlin	12	=head2 node_overfull
266	dpavlin	1
267			Returns if node is overfull
268
269			if ($node->node_overfull) { something }
270
271			=cut
272
273			sub node_overfull {
274			my $self = shift;
275			my $node = shift;
276			$node->size > $self->B;
277			}
278
279	dpavlin	12	=head2 to_string
280	dpavlin	1
281			Returns your tree as formatted string.
282
283			my $text = $root->to_string;
284
285			Mostly usefull for debugging as output leaves much to be desired.
286
287			=cut
288
289			sub to_string {
290			$_[0]->root->to_string;
291			}
292
293	dpavlin	12	=head2 to_dot
294	dpavlin	1
295			Create Graphviz graph of your tree
296
297			my $dot_graph = $root->to_dot;
298
299			=cut
300
301			sub to_dot {
302			my $self = shift;
303
304			my $dot = qq/digraph dns {\nrankdir=LR;\n/;
305			$dot .= $self->root->to_dot;
306			$dot .= qq/\n}\n/;
307
308			return $dot;
309			}
310
311	dpavlin	12	=head2 to_jsfind
312	dpavlin	1
313			Create xml index files for jsFind. This should be called after
314			your B-Tree has been filled with data.
315
316			$root->to_jsfind('/full/path/to/index/dir/');
317
318			Returns number of nodes in created tree.
319
320	dpavlin	9	There is also longer version if you want to recode your data charset
321			into different one (probably UTF-8):
322
323			$root->to_jsfind('/full/path/to/index/dir/','ISO-8859-2','UTF-8');
324
325	dpavlin	11	Destination encoding is UTF-8 by default, so you don't have to specify it.
326
327			$root->to_jsfind('/full/path/to/index/dir/','WINDOWS-1250');
328
329	dpavlin	1	=cut
330
331	dpavlin	9	my $iconv;
332	dpavlin	11	my $iconv_l1;
333	dpavlin	9
334	dpavlin	1	sub to_jsfind {
335			my $self = shift;
336
337			my $path = shift \|\| confess "to_jsfind need path to your index!";
338
339	dpavlin	9	my ($from_cp,$to_cp) = @_;
340	dpavlin	11
341			$to_cp \|\|= 'UTF-8';
342
343	dpavlin	9	if ($from_cp && $to_cp) {
344			$iconv = Text::Iconv->new($from_cp,$to_cp);
345			}
346	dpavlin	11	$iconv_l1 = Text::Iconv->new('ISO-8859-1',$to_cp);
347	dpavlin	9
348	dpavlin	1	$path .= "/" if ($path =~ /\/$/);
349	dpavlin	11	#carp "creating directory for index '$path'" if (! -w $path);
350	dpavlin	1
351			return $self->root->to_jsfind($path,"0");
352			}
353
354
355			# private, default cmd function
356			sub default_cmp {
357			$_[0] cmp $_[1];
358			}
359
360	dpavlin	12	=head2 _recode
361	dpavlin	9
362			This is internal function to recode charset.
363
364	dpavlin	12	It will also try to decode entities in data using L<HTML::Entities>.
365	dpavlin	11
366	dpavlin	9	=cut
367
368			sub _recode {
369			my $self = shift;
370			my $text = shift \|\| return;
371
372	dpavlin	11	sub _decode_html_entities {
373			my $data = shift \|\| return;
374			$data = $iconv_l1->convert(decode_entities($data)) \|\| croak "entity decode problem: $data";
375			}
376
377	dpavlin	9	if ($iconv) {
378	dpavlin	11	$text = $iconv->convert($text) \|\| $text && carp "convert problem: $text";
379			$text =~ s/(\&\w+;)/_decode_html_entities($1)/ges;
380	dpavlin	9	}
381	dpavlin	11
382			return $text;
383	dpavlin	9	}
384
385	dpavlin	1	#####################################################################
386
387	dpavlin	12	=head1 jsFind::Node methods
388	dpavlin	1
389			Each node has C<k> key-data pairs, with C<B> <= C<k> <= C<2B>, and
390			each has C<k+1> subnodes, which might be null.
391
392			The node is a blessed reference to a list with three elements:
393
394			($keylist, $datalist, $subnodelist)
395
396			each is a reference to a list list.
397
398			The null node is represented by a blessed reference to an empty list.
399
400			=cut
401
402			package jsFind::Node;
403
404			use warnings;
405			use strict;
406
407			use Carp;
408			use File::Path;
409	dpavlin	9	use Text::Iconv;
410	dpavlin	1
411	dpavlin	9	use base 'jsFind';
412
413	dpavlin	1	my $KEYS = 0;
414			my $DATA = 1;
415			my $SUBNODES = 2;
416
417	dpavlin	12	=head2 new
418	dpavlin	1
419			Create New node
420
421			my $node = new jsFind::Node ($keylist, $datalist, $subnodelist);
422
423			You can also mit argument list to create empty node.
424
425			my $empty_node = new jsFind::Node;
426
427			=cut
428
429			sub new {
430			my $self = shift;
431			my $package = ref $self \|\| $self;
432			croak "Internal error: jsFind::Node::new called with wrong number of arguments."
433			unless @_ == 3 \|\| @_ == 0;
434			bless [@_] => $package;
435			}
436
437	dpavlin	12	=head2 locate_key
438	dpavlin	1
439			Locate key in node using linear search. This should probably be replaced
440			by binary search for better performance.
441
442			my ($found, $index) = $node->locate_key($key, $cmp_coderef);
443
444			Argument C<$cmp_coderef> is optional reference to custom comparison
445			operator.
446
447			Returns (1, $index) if $key[$index] eq $key.
448
449			Returns (0, $index) if key could be found in $subnode[$index].
450
451			In scalar context, just returns 1 or 0.
452
453			=cut
454
455			sub locate_key {
456			# Use linear search for testing, replace with binary search.
457			my $self = shift;
458			my $key = shift;
459			my $cmp = shift \|\| \&jsFind::default_cmp;
460			my $i;
461			my $cmp_result;
462			my $N = $self->size;
463			for ($i = 0; $i < $N; $i++) {
464			$cmp_result = &$cmp($key, $self->key($i));
465			last if $cmp_result <= 0;
466			}
467
468			# $i is now the index of the first node-key greater than $key
469			# or $N if there is no such. $cmp_result is 0 iff the key was found.
470			(!$cmp_result, $i);
471			}
472
473
474	dpavlin	12	=head2 emptynode
475	dpavlin	1
476			Creates new empty node
477
478			$node = $root->emptynode;
479			$new_node = $node->emptynode;
480
481			=cut
482
483			sub emptynode {
484			new($_[0]); # Pass package name, but not anything else.
485			}
486
487	dpavlin	12	=head2 is_empty
488	dpavlin	1
489			Test if node is empty
490
491			if ($node->is_empty) { something }
492
493			=cut
494
495			# undef is empty; so is a blessed empty list.
496			sub is_empty {
497			my $self = shift;
498			!defined($self) \|\| $#$self < 0;
499			}
500
501	dpavlin	12	=head2 key
502	dpavlin	1
503			Return C<$i>th key from node
504
505			my $key = $node->key($i);
506
507			=cut
508
509			sub key {
510			# my ($self, $n) = @_;
511			# $self->[$KEYS][$n];
512
513			# speedup
514			$_[0]->[$KEYS][$_[1]];
515			}
516
517	dpavlin	12	=head2 data
518	dpavlin	1
519			Return C<$i>th data from node
520
521			my $data = $node->data($i);
522
523			=cut
524
525			sub data {
526			my ($self, $n) = @_;
527			$self->[$DATA][$n];
528			}
529
530	dpavlin	12	=head2 kdp_replace
531	dpavlin	1
532			Set key data pair for C<$i>th element in node
533
534			$node->kdp_replace($i, "key value" => {
535			"data key 1" => "data value 1",
536			"data key 2" => "data value 2",
537			};
538
539			=cut
540
541			sub kdp_replace {
542			my ($self, $n, $k => $d) = @_;
543			if (defined $k) {
544			$self->[$KEYS][$n] = $k;
545			$self->[$DATA][$n] = $d;
546			}
547			[$self->[$KEYS][$n],
548			$self->[$DATA][$n]];
549			}
550
551	dpavlin	12	=head2 kdp_insert
552	dpavlin	1
553	dpavlin	12	Insert key/data pair in tree
554	dpavlin	1
555	dpavlin	12	$node->kdp_insert("key value" => "data value");
556
557			No return value.
558
559	dpavlin	1	=cut
560
561			sub kdp_insert {
562			my $self = shift;
563			my ($k => $d) = @_;
564			my ($there, $where) = $self->locate_key($k) unless $self->is_empty;
565
566			if ($there) { croak("Tried to insert `$k => $d' into node where `$k' was already present."); }
567
568			# undef fix
569			$where \|\|= 0;
570
571			splice(@{$self->[$KEYS]}, $where, 0, $k);
572			splice(@{$self->[$DATA]}, $where, 0, $d);
573			splice(@{$self->[$SUBNODES]}, $where, 0, undef);
574			}
575
576	dpavlin	12	=head2 kdp_append
577	dpavlin	1
578			Adds new data keys and values to C<$i>th element in node
579
580			$node->kdp_append($i, "key value" => {
581			"added data key" => "added data value",
582			};
583
584			=cut
585
586			sub kdp_append {
587			my ($self, $n, $k => $d) = @_;
588			if (defined $k) {
589			$self->[$KEYS][$n] = $k;
590			my ($kv,$dv) = %{$d};
591			$self->[$DATA][$n]->{$kv} = $dv;
592			}
593			[$self->[$KEYS][$n],
594			$self->[$DATA][$n]];
595			}
596
597	dpavlin	12	=head2 subnode
598	dpavlin	1
599			Set new or return existing subnode
600
601			# return 4th subnode
602			my $my_node = $node->subnode(4);
603
604			# create new subnode 5 from $my_node
605			$node->subnode(5, $my_node);
606
607			=cut
608
609			sub subnode {
610			my ($self, $n, $newnode) = @_;
611			$self->[$SUBNODES][$n] = $newnode if defined $newnode;
612			$self->[$SUBNODES][$n];
613			}
614
615	dpavlin	12	=head2 is_leaf
616	dpavlin	1
617			Test if node is leaf
618
619			if ($node->is_leaf) { something }
620
621			=cut
622
623			sub is_leaf {
624			my $self = shift;
625			! defined $self->[$SUBNODES][0]; # undefined subnode means leaf node.
626			}
627
628	dpavlin	12	=head2 size
629	dpavlin	1
630			Return number of keys in the node
631
632			my $nr = $node->size;
633
634			=cut
635
636			sub size {
637			my $self = shift;
638			return scalar(@{$self->[$KEYS]});
639			}
640
641	dpavlin	12	=head2 halves
642	dpavlin	1
643	dpavlin	12	Split node into two halves so that keys C<0 .. $n-1> are in one node
644			and keys C<$n+1 ... $size> are in the other.
645	dpavlin	1
646	dpavlin	12	my ($left_node, $right_node, $kdp) = $node->halves($n);
647
648	dpavlin	1	=cut
649
650			sub halves {
651			my $self = shift;
652			my $n = shift;
653			my $s = $self->size;
654			my @right;
655			my @left;
656
657			$left[$KEYS] = [@{$self->[$KEYS]}[0 .. $n-1]];
658			$left[$DATA] = [@{$self->[$DATA]}[0 .. $n-1]];
659			$left[$SUBNODES] = [@{$self->[$SUBNODES]}[0 .. $n]];
660
661			$right[$KEYS] = [@{$self->[$KEYS]}[$n+1 .. $s-1]];
662			$right[$DATA] = [@{$self->[$DATA]}[$n+1 .. $s-1]];
663			$right[$SUBNODES] = [@{$self->[$SUBNODES]}[$n+1 .. $s]];
664
665			my @middle = ($self->[$KEYS][$n], $self->[$DATA][$n]);
666
667			($self->new(@left), $self->new(@right), \@middle);
668			}
669
670	dpavlin	12	=head2 to_string
671	dpavlin	1
672			Dumps tree as string
673
674			my $str = $root->to_string;
675
676			=cut
677
678			sub to_string {
679			my $self = shift;
680			my $indent = shift \|\| 0;
681			my $I = ' ' x $indent;
682			return '' if $self->is_empty;
683			my ($k, $d, $s) = @$self;
684			my $result = '';
685			$result .= defined($s->[0]) ? $s->[0]->to_string($indent+2) : '';
686			my $N = $self->size;
687			my $i;
688			for ($i = 0; $i < $N; $i++) {
689			# $result .= $I . "$k->[$i] => $d->[$i]\n";
690			$result .= $I . "$k->[$i]\n";
691			$result .= defined($s->[$i+1]) ? $s->[$i+1]->to_string($indent+2) : '';
692			}
693			$result;
694			}
695
696			=begin comment
697
698			use Data::Dumper;
699
700			sub to_string {
701			my $self = shift;
702			my $indent = shift \|\| 0;
703			my $path = shift \|\| '0';
704			return '' if $self->is_empty;
705			my ($k, $d, $s) = @$self;
706			my $result = '';
707			$result .= defined($s->[0]) ? $s->[0]->to_string($indent+1,"$path/0") : '';
708			my $N = $self->size;
709			for (my $i = 0; $i < $N; $i++) {
710			my $dump = Dumper($d->[$i]);
711			$dump =~ s/[\n\r\s]+/ /gs;
712			$dump =~ s/\$VAR1\s=\s//;
713			$result .= sprintf("%-5s [%2d] %2s: %s => %s\n", $path, $i, $indent, $k->[$i], $dump);
714			$result .= defined($s->[$i+1]) ? $s->[$i+1]->to_string($indent+1,"$path/$i") : '';
715			}
716			$result;
717			}
718
719			=end comment
720
721	dpavlin	12	=head2 to_dot
722	dpavlin	1
723			Recursivly walk nodes of tree
724
725			=cut
726
727			sub to_dot {
728			my $self = shift;
729			my $parent = shift;
730
731			return '' if $self->is_empty;
732
733			my $dot = '';
734
735			my ($k, $d, $s) = @$self;
736			my $N = $self->size;
737
738			my @dot_keys;
739
740			my $node_name = $parent \|\| '_';
741			$node_name =~ s/\W+//g;
742			$node_name .= " [$N]";
743
744			for (my $i = 0; $i <= $N; $i++) {
745			if (my $key = $k->[$i]) {
746			push @dot_keys, qq{<$i>$key};
747			}
748			$dot .= $s->[$i]->to_dot(qq{"$node_name":$i}) if ($s->[$i]);
749			}
750			push @dot_keys, qq{<$N>...} if (! $self->is_leaf);
751
752			my $label = join("\|",@dot_keys);
753			$dot .= qq{"$node_name" [ shape=record, label="$label" ];\n};
754
755			$dot .= qq{$parent -> "$node_name";\n} if ($parent);
756
757			$dot;
758			}
759
760	dpavlin	12	=head2 to_xml
761	dpavlin	11
762			Escape <, >, & and ", and to produce valid XML
763
764			=cut
765
766			my %escape = ('<'=>'<', '>'=>'>', '&'=>'&', '"'=>'"');
767			my $escape_re = join '\|' => keys %escape;
768
769			sub to_xml {
770			my $self = shift \|\| confess "you should call to_xml as object!";
771
772			my $d = shift \|\| return;
773			$d = $self->SUPER::_recode($d);
774			confess "escape_re undefined!" unless ($escape_re);
775			$d =~ s/($escape_re)/$escape{$1}/g;
776			return $d;
777			}
778
779	dpavlin	12	=head2 to_jsfind
780	dpavlin	1
781			Create jsFind xml files
782
783	dpavlin	8	my $nr=$tree->to_jsfind('/path/to/index','0');
784	dpavlin	1
785			Returns number of elements created
786
787			=cut
788
789	dpavlin	11
790	dpavlin	1	sub to_jsfind {
791			my $self = shift;
792			my ($path,$file) = @_;
793
794			return 0 if $self->is_empty;
795
796	dpavlin	8	confess("path is undefined.") unless ($path);
797			confess("file is undefined. Did you call \$t->root->to_jsfind(..) instead of \$t->to_jsfind(..) ?") unless (defined($file));
798
799	dpavlin	1	my $nr_keys = 0;
800
801			my ($k, $d, $s) = @$self;
802			my $N = $self->size;
803
804			my ($key_xml, $data_xml) = ("<n>","<d>");
805
806			for (my $i = 0; $i <= $N; $i++) {
807			my $key = lc($k->[$i]);
808
809			if ($key) {
810	dpavlin	11	$key_xml .= '<k>'.$self->to_xml($key).'</k>';
811			$data_xml .= '<e>';
812	dpavlin	1	#use Data::Dumper;
813			#print Dumper($d->[$i]);
814			foreach my $path (keys %{$d->[$i]}) {
815	dpavlin	11	$data_xml .= '<l f="'.($d->[$i]->{$path}->{'f'} \|\| 1).'" t="'.$self->to_xml($d->[$i]->{$path}->{'t'} \|\| 'no title').'">'.$self->to_xml($path).'</l>';
816	dpavlin	1	$nr_keys++;
817			}
818	dpavlin	11	$data_xml .= '</e>';
819	dpavlin	1	}
820
821			$nr_keys += $s->[$i]->to_jsfind("$path/$file","$i") if ($s->[$i]);
822			}
823
824	dpavlin	11	$key_xml .= '</n>';
825			$data_xml .= '</d>';
826	dpavlin	1
827			if (! -e $path) {
828			mkpath($path) \|\| croak "can't create dir '$path': $!";
829			}
830
831			open(K, "> ${path}/${file}.xml") \|\| croak "can't open '$path/$file.xml': $!";
832			open(D, "> ${path}/_${file}.xml") \|\| croak "can't open '$path/_$file.xml': $!";
833
834	dpavlin	11	print K $key_xml;
835			print D $data_xml;
836	dpavlin	1
837			close(K);
838			close(D);
839
840			return $nr_keys;
841			}
842
843			1;
844			__END__
845
846			=head1 SEE ALSO
847
848			jsFind web site L<http://www.elucidsoft.net/projects/jsfind/>
849
850			B-Trees in perl web site L<http://perl.plover.com/BTree/>
851
852	dpavlin	14	This module web site L<http://www.rot13.org/~dpavlin/jsFind.html>
853
854	dpavlin	1	=head1 AUTHORS
855
856			Mark-Jonson Dominus E<lt>mjd@pobox.comE<gt> wrote C<BTree.pm> which was
857			base for this module
858
859			Shawn P. Garbett E<lt>shawn@elucidsoft.netE<gt> wrote jsFind
860
861			Dobrica Pavlinusic E<lt>dpavlin@rot13.orgE<gt> wrote this module
862
863			=head1 COPYRIGHT AND LICENSE
864
865			Copyright (C) 2004 by Dobrica Pavlinusic
866
867			This program is free software; you can redistribute it and/or modify it
868			under the terms of the GNU General Public License as published by the Free
869			Software Foundation; either version 2 of the License, or (at your option)
870			any later version. This program is distributed in the hope that it will be
871			useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
872			MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General
873			Public License for more details.
874
875			=cut