File Coverage

blib/lib/Text/Structured.pm
Criterion Covered Total %
statement 33 38 86.8
branch 3 12 25.0
condition 3 9 33.3
subroutine 6 7 85.7
pod 4 4 100.0
total 49 70 70.0


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Text::Structured - Manipulate fixed-format pages
4              
5             =head1 SYNOPSIS
6              
7             use Text::Structured;
8             $st = new Text::Structured($page);
9             $foo = $st->get_text_at($r,$c,$len);
10             $foo = $st->get_text_re($r,$re);
11              
12             =head1 DESCRIPTION
13              
14             B is a class for manipulating fixed-format pages of
15             text. A page is treated as a series of rows and columns with the row
16             and column of the top left hand corner of the page being (0,0).
17              
18             =head1 SUPERCLASSES
19              
20             B
21              
22             =cut
23              
24             package Text::Structured;
25              
26 1     1   5839 use strict;
  1         2  
  1         35  
27 1     1   6 use base qw/Text::StructuredBase/;
  1         3  
  1         632  
28 1     1   7 use vars qw($VERSION);
  1         2  
  1         644  
29              
30             $VERSION = '0.02';
31              
32             my %fields = (
33             PAGE_L => undef,
34             );
35              
36             ##-----------------------------------------------------------------------------
37             ## CLASS METHODS
38             ##-----------------------------------------------------------------------------
39              
40             =head1 CLASS METHODS
41              
42             =head2 new($page)
43              
44             Create a new B object. I<$page> is a string
45             containing a page of text.
46              
47             =cut
48              
49             sub new {
50 1     1 1 14 my $proto = shift;
51 1   33     9 my $class = ref($proto) || $proto;
52 1         8 my $self = bless { _PERMITTED => \%fields, %fields}, $class;
53 1         2 my @page;
54 1         17 for ( split /\n/,shift ) { push(@page,[ length, $_ ]) };
  35         78  
55 1         20 $self->page_l(\@page);
56 1         4 return $self;
57             };
58              
59             ##----------------------------------------------------------------------------
60             ## OBJECT METHODS
61             ##-----------------------------------------------------------------------------
62              
63             ## AUTOLOAD() methods
64              
65             =head1 OBJECT METHODS
66              
67             =head2 get_text_at($r,$c,$len)
68              
69             Returns a substring of length I<$len> starting at row I<$r>, column
70             I<$c>. This method will die() if I<$r> E 0 or I<$r> E the
71             number of lines in the page. See also L.
72              
73             =cut
74              
75             sub get_text_at($$$) {
76 3     3 1 171 my $self = shift;
77 3         6 my($r,$c,$len) = @_;
78 3         3 my @page = @{$self->page_l};
  3         14  
79 3 50 33     32 die "You specified row $r but there are $#page rows in the page"
80             if $r > $#page or $r < 0;
81 3         6 my $row = $page[$r];
82 3         62 return substr $row->[1],$c,$len;
83             }
84              
85             #------------------------------------------------------------------------------
86              
87             =head2 get_text_re($r,$re)
88              
89             Returns a string which is the result of applying the regular
90             expression I<$re> to row I<$r> of the page. This method will die() if
91             I<$r> E 0 or I<$r> E the number of lines in the page.
92              
93             =cut
94              
95             sub get_text_re($$) {
96 1     1 1 2 my $self = shift;
97 1         3 my($r,$re) = @_;
98 1         2 my @page = @{$self->page_l};
  1         4  
99 1 50 33     7 die "You specified row $r but there are $#page rows in the page"
100             if $r > $#page or $r < 0;
101 1         2 my $row = $page[$r];
102 1         24 my @matches = $row->[1] =~ /$re/;
103 1 50       4 print STDERR "row = $row->[1], re = $re, matches = @matches\n"
104             if $self->{_DEBUG};
105 1         7 return "@matches";
106             }
107              
108             #------------------------------------------------------------------------------
109              
110             =head2 do_method()
111              
112             This method can be used with the B module (available
113             from CPAN) to fill a template using methods from B
114             e.g.
115              
116             use Text::FillIn;
117             use Text::Structured;
118              
119             $page = q{foo bar
120             baz quux};
121             $st = new Text::Structured($page);
122             # set delimiters
123             Text::FillIn->Ldelim('(:');
124             Text::FillIn->Rdelim(':)');
125             $template = new Text::FillIn;
126             $template->object($st);
127             $template->hook('&','do_method');
128             $template->set_text(q{Oh (:&get_text_at(0,0,3):), it's a (:&get_text_re(1,(\w+)$):)!});
129             $foo = $template->interpret;
130             print "$foo\n";
131              
132             Prints 'Oh foo, it's a quux!'.
133              
134             =cut
135              
136             sub do_method {
137 0     0 1   my $self = shift;
138 0 0         print STDERR "args = $_[0]\n" if $self->{_DEBUG};
139 0 0         my($method,$args) = $_[0] =~ /(\w+)\((.*)\)/ or die ("Bad slot: $_[0]");
140 0 0         print STDERR "About to \$self->$method($args)\n" if $self->{_DEBUG};
141 0           return $self->$method(split/,/,$args);
142             }
143              
144             1;
145              
146             =head1 AUTHOR
147              
148             Paul Sharpe Epaul@miraclefish.comE
149              
150             =head1 COPYRIGHT
151              
152             Copyright (c) 1999 Paul Sharpe. England. All rights reserved. This
153             program is free software; you can redistribute it and/or modify it
154             under the same terms as Perl itself.
155              
156             =cut