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

package Socialtext::WikiObject;
use strict;
use warnings;
use Carp;
use Data::Dumper;

=head1 NAME

Socialtext::WikiObject - Represent wiki markup as a data structure and object

=cut

our $VERSION = '0.03';

=head1 SYNOPSIS

  use Socialtext::WikiObject;
  my $page = Socialtext::WikiObject->new(
                rester => $Socialtext_Rester,
                page => $wiki_page_name,
             );

=head1 DESCRIPTION

Socialtext::WikiObject is a package that attempts to fetch and parse some wiki
text into a perl data structure.  This makes it easier for tools to access
information stored on the wiki.

The goal of Socialtext::WikiObject is to create a structure that is 'good
enough' for most cases.

The wiki data is parsed into a data structure intended for easy access to the
data.  Headings, lists and text are supported.  Simple tables without multi-line
rows are parsed.

Subclass Socialtext::WikiObject to create a custom module for your data.  You
can provide accessors into the parsed wiki data.

Subclasses can simply provide accessors into the data they wish to expose.

=head1 FUNCTIONS

=head2 new( %opts )

Create a new wiki object.  Options:

=over 4

=item rester

Users must provide a Socialtext::Resting object setup to use the desired
workspace and server.

=item page

If the page is given, it will be loaded immediately.

=back

=cut

our $DEBUG = 0;

sub new {
   my ($class, %opts) = @_;
   croak "rester is mandatory!" unless $opts{rester};

   my $self = { %opts };
   bless $self, $class;

   $self->load_page if $self->{page};
   return $self;
}

=head2 load_page( $page_name )

Load the specified page.  Will fetch the wiki page and parse
it into a perl data structure.

=cut

sub load_page {
    my $self = shift;
    my $page = $self->{page} = shift || $self->{page};
    croak "Must supply a page to load!" unless $page;
    my $rester = $self->{rester};
    my $wikitext = $rester->get_page($page);
    return unless $wikitext;

    $self->parse_wikitext($wikitext);
}

=head2 parse_wikitext( $wikitext )

Parse the wikitext into a data structure.

=cut

sub parse_wikitext {
    my $self = shift;
    my $wikitext = shift;

    $self->_find_smallest_heading($wikitext);
    $self->{parent_stack} = [];
    $self->{base_obj} = $self;

    for my $line (split "\n", $wikitext) {
        # whitespace
	if ($line =~ /^\s*$/) {
            $self->_add_whitespace;
        }
        # Header line
	elsif ($line =~ m/^(\^\^*)\s+(.+?):?\s*$/) {
            $self->_add_heading($1, $2);
	}
        # Lists
	elsif ($line =~ m/^[#\*]\s+(.+)/) {
            $self->_add_list_item($1);
	}
        # Tables
        elsif ($line =~ m/^\|\s*(.+?)\s*\|$/) {
            $self->_add_table_row($1);
        }
        else {
            $self->_add_text($line);
        }
    }

    $self->_finish_parse;
    warn Dumper $self if $DEBUG;
}

sub _add_whitespace {}

sub _finish_parse {
    my $self = shift;

    delete $self->{current_heading};
    delete $self->{base_obj};
    delete $self->{heading_level_start};
    delete $self->{parent_stack};
}

sub _add_heading {
    my $self = shift;
    my $heading_level = length(shift || '') - $self->{heading_level_start};
    my $new_heading = shift;
    warn "hl=$heading_level hls=$self->{heading_level_start} ($new_heading)\n" if $DEBUG;
    push @{$self->{headings}}, $new_heading;

    my $cur_heading = $self->{current_heading};
    while (@{$self->{parent_stack}} > $heading_level) {
        warn "going down" if $DEBUG;
        # Down a header level
        pop @{$self->{parent_stack}};
    }
    if ($heading_level > @{$self->{parent_stack}}) {
        if ($cur_heading) {
            warn "going up $cur_heading ($new_heading)" if $DEBUG;
            # Down a header level
            # Up a level - create a new node
            push @{$self->{parent_stack}}, $cur_heading;
            my $old_obj = $self->{base_obj};
            $self->{base_obj} = { name => $cur_heading };
            $self->{base_obj}{text} = $old_obj->{$cur_heading}
                if $cur_heading and $old_obj->{$cur_heading};

            # update previous base' - @items and direct pointers
            push @{ $old_obj->{items} }, $self->{base_obj};
            $old_obj->{$cur_heading} = $self->{base_obj};
            $old_obj->{lc($cur_heading)} = $self->{base_obj};
        }
        else {
            warn "Going up, no previous heading ($new_heading)\n" if $DEBUG;
        }
    }
    else {
        warn "Something... ($new_heading)\n" if $DEBUG;
        warn "ch=$cur_heading\n" if $DEBUG and $cur_heading;
        $self->{base_obj} = $self;
        for (@{$self->{parent_stack}}) {
            $self->{base_obj} = $self->{base_obj}{$_} || die "Can't find $_";
        }
    }
    $self->{current_heading} = $new_heading;
    warn "Current heading: $self->{current_heading}\n" if $DEBUG;
}

sub _add_text {
    my $self = shift;
    my $line = shift;

    # Text under a heading
    my $cur_heading = $self->{current_heading};
    if ($cur_heading) {
        if (ref($self->{base_obj}{$cur_heading}) eq 'ARRAY') {
            $self->{base_obj}{$cur_heading} = {
                items => $self->{base_obj}{$cur_heading},
                text => "$line\n",
            }
        }
        elsif (ref($self->{base_obj}{$cur_heading}) eq 'HASH') {
            $self->{base_obj}{$cur_heading}{text} .= "$line\n";
        }
        else {
            $self->{base_obj}{$cur_heading} .= "$line\n";
        }
        $self->{base_obj}{lc($cur_heading)} = $self->{base_obj}{$cur_heading};
    }
    # Text without a heading
    else {
        $self->{base_obj}{text} .= "$line\n";
    }
}

sub _add_list_item {
    my $self = shift;
    my $item = shift;

    $self->_add_array_field('items', $item);
}

sub _add_table_row {
    my $self = shift;
    my $line = shift;

    my @cols = split /\s*\|\s*/, $line;
    $self->_add_array_field('table', \@cols);
}

sub _add_array_field {
    my $self = shift;
    my $field_name = shift;
    my $item = shift;

    my $field = $self->{current_heading} || $field_name;
    my $bobj = $self->{base_obj};
    if (! exists $bobj->{$field} or ref($bobj->{$field}) eq 'ARRAY') {
        push @{$bobj->{$field}}, $item;
    }
    elsif (ref($bobj->{$field}) eq 'HASH') {
        push @{$bobj->{$field}{$field_name}}, $item;
    }
    else {
        my $text = $bobj->{$field};
        $bobj->{$field} = {
            text => $text,
            $field_name => [ $item ],
        };
    }
    $bobj->{lc($field)} = $bobj->{$field};
}

sub _find_smallest_heading {
    my $self = shift;
    my $text = shift;

    my $big = 99;
    my $heading = $big;
    while ($text =~ m/^(\^+)\s/mg) {
        my $len = length($1);
        $heading = $len if $len < $heading;
    }
    $self->{heading_level_start} = $heading == $big ? 1 : $heading;
}

=head1 AUTHOR

Luke Closs, C<<  >>

=head1 BUGS

Please report any bugs or feature requests to
C, or through the web interface at
L.
I will be notified, and then you'll automatically be notified of progress on
your bug as I make changes.

=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc Socialtext::EditPage

You can also look for information at:

=over 4

=item * AnnoCPAN: Annotated CPAN documentation

L

=item * CPAN Ratings

L

=item * RT: CPAN's request tracker

L

=item * Search CPAN

L

=back

=head1 ACKNOWLEDGEMENTS

=head1 COPYRIGHT & LICENSE

Copyright 2006 Luke Closs, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;