File Coverage

blib/lib/Socialtext/WikiObject.pm
Criterion Covered Total %
statement 117 117 100.0
branch 41 52 78.8
condition 11 19 57.8
subroutine 15 15 100.0
pod 3 3 100.0
total 187 206 90.7


line stmt bran cond sub pod time code
1             package Socialtext::WikiObject;
2 5     5   40213 use strict;
  5         14  
  5         166  
3 5     5   29 use warnings;
  5         10  
  5         121  
4 5     5   25 use Carp;
  5         8  
  5         408  
5 5     5   2608 use Data::Dumper;
  5         12810  
  5         9469  
6              
7             =head1 NAME
8              
9             Socialtext::WikiObject - Represent wiki markup as a data structure and object
10              
11             =cut
12              
13             our $VERSION = '0.03';
14              
15             =head1 SYNOPSIS
16              
17             use Socialtext::WikiObject;
18             my $page = Socialtext::WikiObject->new(
19             rester => $Socialtext_Rester,
20             page => $wiki_page_name,
21             );
22              
23             =head1 DESCRIPTION
24              
25             Socialtext::WikiObject is a package that attempts to fetch and parse some wiki
26             text into a perl data structure. This makes it easier for tools to access
27             information stored on the wiki.
28              
29             The goal of Socialtext::WikiObject is to create a structure that is 'good
30             enough' for most cases.
31              
32             The wiki data is parsed into a data structure intended for easy access to the
33             data. Headings, lists and text are supported. Simple tables without multi-line
34             rows are parsed.
35              
36             Subclass Socialtext::WikiObject to create a custom module for your data. You
37             can provide accessors into the parsed wiki data.
38              
39             Subclasses can simply provide accessors into the data they wish to expose.
40              
41             =head1 FUNCTIONS
42              
43             =head2 new( %opts )
44              
45             Create a new wiki object. Options:
46              
47             =over 4
48              
49             =item rester
50              
51             Users must provide a Socialtext::Resting object setup to use the desired
52             workspace and server.
53              
54             =item page
55              
56             If the page is given, it will be loaded immediately.
57              
58             =back
59              
60             =cut
61              
62             our $DEBUG = 0;
63              
64             sub new {
65 14     14 1 1925 my ($class, %opts) = @_;
66 14 100       231 croak "rester is mandatory!" unless $opts{rester};
67              
68 13         52 my $self = { %opts };
69 13         36 bless $self, $class;
70            
71 13 50       277 $self->load_page if $self->{page};
72 13         65 return $self;
73             }
74              
75             =head2 load_page( $page_name )
76              
77             Load the specified page. Will fetch the wiki page and parse
78             it into a perl data structure.
79              
80             =cut
81              
82             sub load_page {
83 13     13 1 23 my $self = shift;
84 13   33     104 my $page = $self->{page} = shift || $self->{page};
85 13 50       34 croak "Must supply a page to load!" unless $page;
86 13         23 my $rester = $self->{rester};
87 13         62 my $wikitext = $rester->get_page($page);
88 13 50       41 return unless $wikitext;
89              
90 13         48 $self->parse_wikitext($wikitext);
91             }
92              
93             =head2 parse_wikitext( $wikitext )
94              
95             Parse the wikitext into a data structure.
96              
97             =cut
98              
99             sub parse_wikitext {
100 8     8 1 12 my $self = shift;
101 8         11 my $wikitext = shift;
102              
103 8         26 $self->_find_smallest_heading($wikitext);
104 8         15 $self->{parent_stack} = [];
105 8         23 $self->{base_obj} = $self;
106              
107 8         47 for my $line (split "\n", $wikitext) {
108             # whitespace
109 83 100       500 if ($line =~ /^\s*$/) {
    100          
    100          
    100          
110 28         54 $self->_add_whitespace;
111             }
112             # Header line
113             elsif ($line =~ m/^(\^\^*)\s+(.+?):?\s*$/) {
114 17         34 $self->_add_heading($1, $2);
115             }
116             # Lists
117             elsif ($line =~ m/^[#\*]\s+(.+)/) {
118 19         42 $self->_add_list_item($1);
119             }
120             # Tables
121             elsif ($line =~ m/^\|\s*(.+?)\s*\|$/) {
122 8         24 $self->_add_table_row($1);
123             }
124             else {
125 11         27 $self->_add_text($line);
126             }
127             }
128              
129 8         32 $self->_finish_parse;
130 8 50       26 warn Dumper $self if $DEBUG;
131             }
132              
133 28     28   33 sub _add_whitespace {}
134              
135             sub _finish_parse {
136 8     8   247 my $self = shift;
137              
138 8         121 delete $self->{current_heading};
139 8         17 delete $self->{base_obj};
140 8         14 delete $self->{heading_level_start};
141 8         16 delete $self->{parent_stack};
142             }
143              
144             sub _add_heading {
145 17     17   20 my $self = shift;
146 17   50     59 my $heading_level = length(shift || '') - $self->{heading_level_start};
147 17         977 my $new_heading = shift;
148 17 50       33 warn "hl=$heading_level hls=$self->{heading_level_start} ($new_heading)\n" if $DEBUG;
149 17         18 push @{$self->{headings}}, $new_heading;
  17         266  
150              
151 17         43 my $cur_heading = $self->{current_heading};
152 17         18 while (@{$self->{parent_stack}} > $heading_level) {
  21         58  
153 4 50       9 warn "going down" if $DEBUG;
154             # Down a header level
155 4         5 pop @{$self->{parent_stack}};
  4         7  
156             }
157 17 100       19 if ($heading_level > @{$self->{parent_stack}}) {
  17         37  
158 6 100       10 if ($cur_heading) {
159 5 50       13 warn "going up $cur_heading ($new_heading)" if $DEBUG;
160             # Down a header level
161             # Up a level - create a new node
162 5         6 push @{$self->{parent_stack}}, $cur_heading;
  5         10  
163 5         8 my $old_obj = $self->{base_obj};
164 5         15 $self->{base_obj} = { name => $cur_heading };
165 5 100 66     40 $self->{base_obj}{text} = $old_obj->{$cur_heading}
166             if $cur_heading and $old_obj->{$cur_heading};
167              
168             # update previous base' - @items and direct pointers
169 5         5 push @{ $old_obj->{items} }, $self->{base_obj};
  5         11  
170 5         10 $old_obj->{$cur_heading} = $self->{base_obj};
171 5         14 $old_obj->{lc($cur_heading)} = $self->{base_obj};
172             }
173             else {
174 1 50       5 warn "Going up, no previous heading ($new_heading)\n" if $DEBUG;
175             }
176             }
177             else {
178 11 50       22 warn "Something... ($new_heading)\n" if $DEBUG;
179 11 50 33     30 warn "ch=$cur_heading\n" if $DEBUG and $cur_heading;
180 11         18 $self->{base_obj} = $self;
181 11         12 for (@{$self->{parent_stack}}) {
  11         26  
182 3   50     14 $self->{base_obj} = $self->{base_obj}{$_} || die "Can't find $_";
183             }
184             }
185 17         31 $self->{current_heading} = $new_heading;
186 17 50       46 warn "Current heading: $self->{current_heading}\n" if $DEBUG;
187             }
188              
189             sub _add_text {
190 11     11   15 my $self = shift;
191 11         14 my $line = shift;
192              
193             # Text under a heading
194 11         20 my $cur_heading = $self->{current_heading};
195 11 100       21 if ($cur_heading) {
196 8 100       32 if (ref($self->{base_obj}{$cur_heading}) eq 'ARRAY') {
    100          
197 1         6 $self->{base_obj}{$cur_heading} = {
198             items => $self->{base_obj}{$cur_heading},
199             text => "$line\n",
200             }
201             }
202             elsif (ref($self->{base_obj}{$cur_heading}) eq 'HASH') {
203 1         5 $self->{base_obj}{$cur_heading}{text} .= "$line\n";
204             }
205             else {
206 6         27 $self->{base_obj}{$cur_heading} .= "$line\n";
207             }
208 8         36 $self->{base_obj}{lc($cur_heading)} = $self->{base_obj}{$cur_heading};
209             }
210             # Text without a heading
211             else {
212 3         12 $self->{base_obj}{text} .= "$line\n";
213             }
214             }
215              
216             sub _add_list_item {
217 19     19   23 my $self = shift;
218 19         29 my $item = shift;
219              
220 19         38 $self->_add_array_field('items', $item);
221             }
222              
223             sub _add_table_row {
224 8     8   10 my $self = shift;
225 8         15 my $line = shift;
226              
227 8         43 my @cols = split /\s*\|\s*/, $line;
228 8         23 $self->_add_array_field('table', \@cols);
229             }
230              
231             sub _add_array_field {
232 27     27   31 my $self = shift;
233 27         30 my $field_name = shift;
234 27         28 my $item = shift;
235              
236 27   66     78 my $field = $self->{current_heading} || $field_name;
237 27         32 my $bobj = $self->{base_obj};
238 27 100 100     122 if (! exists $bobj->{$field} or ref($bobj->{$field}) eq 'ARRAY') {
    100          
239 23         25 push @{$bobj->{$field}}, $item;
  23         206  
240             }
241             elsif (ref($bobj->{$field}) eq 'HASH') {
242 2         3 push @{$bobj->{$field}{$field_name}}, $item;
  2         17  
243             }
244             else {
245 2         5 my $text = $bobj->{$field};
246 2         8 $bobj->{$field} = {
247             text => $text,
248             $field_name => [ $item ],
249             };
250             }
251 27         107 $bobj->{lc($field)} = $bobj->{$field};
252             }
253              
254             sub _find_smallest_heading {
255 8     8   10 my $self = shift;
256 8         30 my $text = shift;
257              
258 8         11 my $big = 99;
259 8         9 my $heading = $big;
260 8         50 while ($text =~ m/^(\^+)\s/mg) {
261 17         29 my $len = length($1);
262 17 100       68 $heading = $len if $len < $heading;
263             }
264 8 100       33 $self->{heading_level_start} = $heading == $big ? 1 : $heading;
265             }
266              
267             =head1 AUTHOR
268              
269             Luke Closs, C<< >>
270              
271             =head1 BUGS
272              
273             Please report any bugs or feature requests to
274             C, or through the web interface at
275             L.
276             I will be notified, and then you'll automatically be notified of progress on
277             your bug as I make changes.
278              
279             =head1 SUPPORT
280              
281             You can find documentation for this module with the perldoc command.
282              
283             perldoc Socialtext::EditPage
284              
285             You can also look for information at:
286              
287             =over 4
288              
289             =item * AnnoCPAN: Annotated CPAN documentation
290              
291             L
292              
293             =item * CPAN Ratings
294              
295             L
296              
297             =item * RT: CPAN's request tracker
298              
299             L
300              
301             =item * Search CPAN
302              
303             L
304              
305             =back
306              
307             =head1 ACKNOWLEDGEMENTS
308              
309             =head1 COPYRIGHT & LICENSE
310              
311             Copyright 2006 Luke Closs, all rights reserved.
312              
313             This program is free software; you can redistribute it and/or modify it
314             under the same terms as Perl itself.
315              
316             =cut
317              
318             1;