SWE/Object/Document.pm

package SWE::Object::Document;
use strict;
use warnings;
use SWE::Lang qw/%ContentMediaType/;
use UNIVERSAL::require;

sub new ($%) {
  my $class = shift;
  my $self = bless {@_}, $class;

  return $self;
}

sub new_id ($%) {
  my $self = shift->new (@_);
  
  ## NOTE: MUST be executed in names_lock.

  my $idgen = $self->db->id;
  my $id = $idgen->get_next_id;
  $self->{id} = $id;

  return $self;
} # new_id

sub db { $_[0]->{db} }

sub id { $_[0]->{id} }

sub reblessed : lvalue { $_[0]->{reblessed} }

sub rebless ($) {
  my $self = shift;
  return if $self->reblessed;

  my $ct = $self->content_media_type;
  my $module = $ContentMediaType{$ct}->{module} || $ContentMediaType{'text/x-suikawiki'}->{module};
  $module->require or die $@;
  bless $self, $module;

  $self->reblessed = 1;
}

sub prop ($) {
  my $self = shift;
  return $self->{prop} ||= $self->db->id_prop->get_data ($self->id);
} # prop

sub content_media_type ($) {
  my $self = shift;
  return $self->prop->{'content-type'} // 'text/x-suikawiki';
} # content_media_type

sub associate_names ($$%) {
  my ($self, $names, %args) = @_;

  ## NOTE: names_lock MUST be executed before the invocation.

  my $id = $self->id;
  my $time = $args{time} || time;
  my $sw3_pages = $self->{sw3_pages}; ## TODO: ...

  my $vc = $self->db->vc;

  my $name_prop_db = $self->{name_prop_db}; ## TODO: ...
  local $name_prop_db->{version_control} = $vc;

  my $name_history_db = $self->db->name_history;
  local $name_history_db->{version_control} = $vc;
  
  for my $name (keys %$names) {
    my $name_props = $name_prop_db->get_data ($name);
    unless (defined $name_props) {
      my $sw3id = $sw3_pages->get_data ($name);
      main::convert_sw3_page ($sw3id => $name); ## TODO: ...
      
      $name_props = $name_prop_db->get_data ($name);
      unless (defined $name_props) {
        $name_history_db->append_data ($name => [$time, 'c']);
      }
    }
    
    push @{$name_props->{id} ||= []}, $id;
    $name_props->{name} = $name;
    $name_prop_db->set_data ($name => $name_props);
    
    $name_history_db->append_data ($name => [$time, 'a', $id]);
  }

  my $user = $args{user} || '(anon)';
  $vc->commit_changes ("id=$id created by $user");
} # associate_names

sub update_tfidf ($$) {
  my ($self, $doc) = @_; ## TODO: $doc should not be an argument

  ## It is REQUIRED to lock the $id before the invocation of this
  ## method to keep the consistency of tfidf data for the $id.

  my $id = $self->id;

  my $tfidf_db = $self->db->id_tfidf;

  require SWE::Data::FeatureVector;

  my $deleted_terms = SWE::Data::FeatureVector->parse_stringref
      ($tfidf_db->get_data ($id))->as_key_hashref;

  my $tc = $doc->document_element->text_content;

  ## TODO: use element semantics...

  my $orig_tfs = {};
  my $all_terms = 0;
  main::for_unique_words ($tc => sub {
    $orig_tfs->{$_[0]} = $_[1];
    $all_terms += $_[1];
  }); ## TODO: XXX

  my $names_index_db = $self->db->name_inverted_index;
  $names_index_db->lock;

  my $idgen = $self->db->id;
  my $doc_number = $idgen->get_last_id;
  
  my $terms = SWE::Data::FeatureVector->new;
  for my $term (keys %$orig_tfs) {
    my $n_tf = $orig_tfs->{$term} / $all_terms;
    
    my $df = $names_index_db->get_count ($term);
    my $idf = log ($doc_number / ($df + 1));
      
    my $tfidf = $n_tf * $idf;
    
    $terms->set_tfidf ($term, $tfidf);
    $names_index_db->add_data ($term => $id => $tfidf);

    delete $deleted_terms->{$term};
  }

  for my $term (keys %$deleted_terms) {
    $names_index_db->delete_data ($term, $id);
  }
  
  $tfidf_db->set_data ($id => \( $terms->stringify ));
} # update_tfidf

sub lock ($) {
  my $self = shift;
  my $lock = $self->{lock} ||= $self->{id_locks}->get_lock ($self->id); ## XXX
  $self->{lock_n}++ or $self->lock;
} # lock

sub unlock ($) {
  my $self = shift;
  my $lock = $self->{lock};
  $self->{lock_n}--;
  if ($lock and $self->{lock_n} <= 0) {
    $lock->unlock;
    delete $self->{lock};
    delete $self->{lock_n};
  }
} # unlock

sub to_text ($) {
  my $self = shift;

  return $self->{content_db}->get_data ($self->id); # XXX
} # to_text

sub to_text_media_type ($) {
  my $self = shift;
  return $self->content_media_type;
} # to_text_media_type

sub to_xml_media_type ($) {
  return undef;
} # to_xml_media_type

sub to_xml ($) {
  return undef;
} # to_xml

sub to_html_fragment ($) {
  return (undef, undef);
} # to_html_fragment

1;
1	wakaba	1.1	package SWE::Object::Document;
2			use strict;
3			use warnings;
4	wakaba	1.7	use SWE::Lang qw/%ContentMediaType/;
5			use UNIVERSAL::require;
6	wakaba	1.1
7			sub new ($%) {
8			my $class = shift;
9			my $self = bless {@_}, $class;
10
11			return $self;
12			}
13
14	wakaba	1.3	sub new_id ($%) {
15			my $self = shift->new (@_);
16
17	wakaba	1.4	## NOTE: MUST be executed in names_lock.
18
19	wakaba	1.3	my $idgen = $self->db->id;
20			my $id = $idgen->get_next_id;
21			$self->{id} = $id;
22
23			return $self;
24			} # new_id
25
26	wakaba	1.1	sub db { $_[0]->{db} }
27
28			sub id { $_[0]->{id} }
29
30	wakaba	1.7	sub reblessed : lvalue { $_[0]->{reblessed} }
31
32			sub rebless ($) {
33			my $self = shift;
34			return if $self->reblessed;
35
36			my $ct = $self->content_media_type;
37			my $module = $ContentMediaType{$ct}->{module} \|\| $ContentMediaType{'text/x-suikawiki'}->{module};
38			$module->require or die $@;
39			bless $self, $module;
40
41			$self->reblessed = 1;
42			}
43
44	wakaba	1.8	sub prop ($) {
45			my $self = shift;
46			return $self->{prop} \|\|= $self->db->id_prop->get_data ($self->id);
47			} # prop
48
49	wakaba	1.7	sub content_media_type ($) {
50	wakaba	1.8	my $self = shift;
51			return $self->prop->{'content-type'} // 'text/x-suikawiki';
52			} # content_media_type
53	wakaba	1.7
54	wakaba	1.1	sub associate_names ($$%) {
55			my ($self, $names, %args) = @_;
56
57			## NOTE: names_lock MUST be executed before the invocation.
58
59			my $id = $self->id;
60			my $time = $args{time} \|\| time;
61			my $sw3_pages = $self->{sw3_pages}; ## TODO: ...
62
63			my $vc = $self->db->vc;
64
65			my $name_prop_db = $self->{name_prop_db}; ## TODO: ...
66			local $name_prop_db->{version_control} = $vc;
67
68			my $name_history_db = $self->db->name_history;
69			local $name_history_db->{version_control} = $vc;
70
71			for my $name (keys %$names) {
72			my $name_props = $name_prop_db->get_data ($name);
73			unless (defined $name_props) {
74			my $sw3id = $sw3_pages->get_data ($name);
75			main::convert_sw3_page ($sw3id => $name); ## TODO: ...
76
77			$name_props = $name_prop_db->get_data ($name);
78			unless (defined $name_props) {
79			$name_history_db->append_data ($name => [$time, 'c']);
80			}
81			}
82
83			push @{$name_props->{id} \|\|= []}, $id;
84			$name_props->{name} = $name;
85			$name_prop_db->set_data ($name => $name_props);
86
87			$name_history_db->append_data ($name => [$time, 'a', $id]);
88			}
89
90			my $user = $args{user} \|\| '(anon)';
91			$vc->commit_changes ("id=$id created by $user");
92			} # associate_names
93
94	wakaba	1.2	sub update_tfidf ($$) {
95			my ($self, $doc) = @_; ## TODO: $doc should not be an argument
96
97			## It is REQUIRED to lock the $id before the invocation of this
98			## method to keep the consistency of tfidf data for the $id.
99
100			my $id = $self->id;
101
102			my $tfidf_db = $self->db->id_tfidf;
103
104			require SWE::Data::FeatureVector;
105
106			my $deleted_terms = SWE::Data::FeatureVector->parse_stringref
107			($tfidf_db->get_data ($id))->as_key_hashref;
108
109			my $tc = $doc->document_element->text_content;
110
111			## TODO: use element semantics...
112
113			my $orig_tfs = {};
114			my $all_terms = 0;
115			main::for_unique_words ($tc => sub {
116			$orig_tfs->{$_[0]} = $_[1];
117			$all_terms += $_[1];
118			}); ## TODO: XXX
119
120			my $names_index_db = $self->db->name_inverted_index;
121			$names_index_db->lock;
122
123			my $idgen = $self->db->id;
124			my $doc_number = $idgen->get_last_id;
125
126			my $terms = SWE::Data::FeatureVector->new;
127			for my $term (keys %$orig_tfs) {
128			my $n_tf = $orig_tfs->{$term} / $all_terms;
129
130			my $df = $names_index_db->get_count ($term);
131			my $idf = log ($doc_number / ($df + 1));
132
133			my $tfidf = $n_tf * $idf;
134
135			$terms->set_tfidf ($term, $tfidf);
136			$names_index_db->add_data ($term => $id => $tfidf);
137
138			delete $deleted_terms->{$term};
139			}
140
141			for my $term (keys %$deleted_terms) {
142			$names_index_db->delete_data ($term, $id);
143			}
144
145			$tfidf_db->set_data ($id => \( $terms->stringify ));
146			} # update_tfidf
147
148	wakaba	1.5	sub lock ($) {
149			my $self = shift;
150			my $lock = $self->{lock} \|\|= $self->{id_locks}->get_lock ($self->id); ## XXX
151			$self->{lock_n}++ or $self->lock;
152			} # lock
153
154			sub unlock ($) {
155			my $self = shift;
156			my $lock = $self->{lock};
157			$self->{lock_n}--;
158			if ($lock and $self->{lock_n} <= 0) {
159			$lock->unlock;
160			delete $self->{lock};
161			delete $self->{lock_n};
162			}
163			} # unlock
164
165	wakaba	1.8	sub to_text ($) {
166			my $self = shift;
167
168			return $self->{content_db}->get_data ($self->id); # XXX
169			} # to_text
170
171			sub to_text_media_type ($) {
172			my $self = shift;
173			return $self->content_media_type;
174			} # to_text_media_type
175
176			sub to_xml_media_type ($) {
177			return undef;
178			} # to_xml_media_type
179
180			sub to_xml ($) {
181			return undef;
182			} # to_xml
183
184			sub to_html_fragment ($) {
185			return (undef, undef);
186			} # to_html_fragment
187	wakaba	1.6
188	wakaba	1.1	1;