File Coverage

blib/lib/Org/Parser/Tiny.pm

Criterion	Covered	Total	%
statement	74	131	56.4
branch	17	54	31.4
condition	8	20	40.0
subroutine	11	22	50.0
pod	3	3	100.0
total	113	230	49.1

## no critic: Modules::RequireExplicitPackage

use 5.010001;
use strict;
use warnings;

package Org::Parser::Tiny;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-02-07'; # DATE
our $DIST = 'Org-Parser-Tiny'; # DIST
our $VERSION = '0.005'; # VERSION

sub new {
    my $class = shift;
    bless {}, $class;
}

sub _parse {
    my ($self, $lines, $opts) = @_;

    # stage 1: get todo keywords

    my @undone_keywords;
    my @done_keywords;
    my $linenum = 0;
    while ($linenum < @$lines) {
        my $line = $lines->[$linenum];
        $linenum++;
        if ($line =~ s/^#\+TODO:\s*//) {
            my ($undone_keywords, $done_keywords) =
                $line =~ /^\s*(.*?)\s*\|\s*(.*?)\s*$/
                or die "Line $linenum: Invalid #+TODO: please use ... | ...";
            while ($undone_keywords =~ /(\w+)/g) {
                push @undone_keywords, $1;
            }
            while ($done_keywords =~ /(\w+)/g) {
                push @done_keywords, $1;
            }
        }
    }
    @undone_keywords = ("TODO") unless @undone_keywords;
    @done_keywords   = ("DONE") unless @done_keywords;
    my $undone_re = join("|", @undone_keywords); $undone_re= qr/(?:$undone_re)/;
    my $done_re   = join("|", @done_keywords  ); $done_re  = qr/(?:$done_re)/;

    # stage 2: build nodes

    # a linear list of nodes
    my @nodes = (
        Org::Parser::Tiny::Node::Document->new(),
    );

    $linenum = 0;
    while ($linenum < @$lines) {
        my $line = $lines->[$linenum];
        $linenum++;
        if ($line =~ /^(\*+) (.*)/) {
            #say "D: got headline $line";
            my $level = length($1);
            my $title = $2;
            my $node = Org::Parser::Tiny::Node::Headline->new(
                _str  => $line,
                level => $level,
            );

            # extract todo state
            if ($title =~ s/\s*($undone_re)\s+//) {
                $node->{is_todo} = 1;
                $node->{is_done} = 0;
                $node->{todo_state} = $1;
            } elsif ($title =~ s/\s*($done_re)\s+//) {
                $node->{is_todo} = 1;
                $node->{is_done} = 1;
                $node->{todo_state} = $1;
            } else {
                $node->{is_todo} = 0;
                $node->{is_done} = 0;
                $node->{todo_state} = "";
            }

            # extract tags
            if ($title =~ s/\s+:((?:\w+:)+)$//) {
                my $tags = $1;
                my @tags;
                while ($tags =~ /(\w+)/g) {
                    push @tags, $1;
                }
                $node->{tags} = \@tags;
            }

            $node->{title} = $title;

            # find the first node which has the lower level (or the root node)
            # as the parent node
            my $i = $#nodes;
            while ($i >= 0) {
                if ($i == 0 || $nodes[$i]{level} < $level) {
                    $node->{parent} = $nodes[$i];
                    push @{ $nodes[$i]{children} }, $node;
                    last;
                }
                $i--;
            }
            push @nodes, $node;
        } else {
            $nodes[-1]{preamble} .= $line;
        }
    }

    $nodes[0];
}

sub parse {
    my ($self, $arg, $opts) = @_;
    die "Please specify a defined argument to parse()\n" unless defined($arg);

    $opts ||= {};

    my $lines;
    my $r = ref($arg);
    if (!$r) {
        $lines = [split /^/, $arg];
    } elsif ($r eq 'ARRAY') {
        $lines = [@$arg];
    } elsif ($r eq 'GLOB' || blessed($arg) && $arg->isa('IO::Handle')) {
        #$lines = split(/^/, join("", <$arg>));
        $lines = [<$arg>];
    } elsif ($r eq 'CODE') {
        my @chunks;
        while (defined(my $chunk = $arg->())) {
            push @chunks, $chunk;
        }
        $lines = [split /^/, (join "", @chunks)];
    } else {
        die "Invalid argument, please supply a ".
            "string|arrayref|coderef|filehandle\n";
    }
    $self->_parse($lines, $opts);
}

sub parse_file {
    my ($self, $filename, $opts) = @_;
    $opts ||= {};

    my $content = do {
        open my($fh), "<", $filename or die "Can't open $filename: $!\n";
        local $/;
        scalar(<$fh>);
    };

    $self->parse($content, $opts);
}


# abstract class: Org::Parser::Tiny::Node
package Org::Parser::Tiny::Node;

sub new {
    my ($class, %args) = @_;
    $args{children} //= [];
    bless \%args, $class;
}

sub parent {
    if (@_ > 1) {
        $_[0]{parent} = $_[1];
    }
    $_[0]{parent};
}

sub children {
    if (@_ > 1) {
        $_[0]{children} = $_[1];
    }
    $_[0]{children} || [];
}

sub as_string { $_[0]{_str} }

sub children_as_string { join("", map { $_->as_string } @{ $_[0]->children }) }

# abstract class: Org::Parser::Tiny::HasPreamble
package Org::Parser::Tiny::Node::HasPreamble;

our @ISA = qw(Org::Parser::Tiny::Node);

sub new {
    my ($class, %args) = @_;
    $args{preamble} //= "";
    $class->SUPER::new(%args);
}


# class: Org::Parser::Tiny::Document: top level node
package Org::Parser::Tiny::Node::Document;

our @ISA = qw(Org::Parser::Tiny::Node::HasPreamble);

sub as_string {
    $_[0]->{preamble} . $_[0]->children_as_string;
}


# class: Org::Parser::Tiny::Node::Headline: headline with its content
package Org::Parser::Tiny::Node::Headline;

our @ISA = qw(Org::Parser::Tiny::Node::HasPreamble);

sub level {
    if (@_ > 1) { undef $_[0]{_str}; $_[0]{level} = $_[1] }
    $_[0]{level};
}

sub title {
    if (@_ > 1) { undef $_[0]{_str}; $_[0]{title} = $_[1] }
    $_[0]{title};
}

sub is_todo {
    if (@_ > 1) { undef $_[0]{_str}; $_[0]{is_todo} = $_[1] }
    $_[0]{is_todo};
}

sub is_done {
    if (@_ > 1) { undef $_[0]{_str}; $_[0]{is_done} = $_[1] }
    $_[0]{is_done};
}

sub todo_state {
    if (@_ > 1) { undef $_[0]{_str}; $_[0]{todo_state} = $_[1] }
    $_[0]{todo_state};
}

sub tags {
    if (@_ > 1) { undef $_[0]{_str}; $_[0]{tags} = $_[1] }
    $_[0]{tags} || [];
}

sub header_as_string {
    ($_[0]->{_str} //
         join('',
              "*" x $_[0]{level},
              " ",
              (length $_[0]{todo_state} ? "$_[0]{todo_state} " : ""),
              "$_[0]{title}",
              (defined $_[0]{tags} ? " :".join(":", @{ $_[0]{tags} }).":" : ""),
              "\n",
          ));
}

sub as_string {
    $_[0]->header_as_string .
        $_[0]->{preamble} .
        $_[0]->children_as_string;
}

1;
# ABSTRACT: Parse Org documents with as little code (and no non-core deps) as possible

__END__