File Coverage

blib/lib/Text/Wrap/OO.pm
Criterion Covered Total %
statement 217 240 90.4
branch 97 130 74.6
condition 1 2 50.0
subroutine 32 54 59.2
pod 14 36 38.8
total 361 462 78.1


line stmt bran cond sub pod time code
1             # ABSTRACT: an object oriented interface to Text::Wrap
2              
3             ######################################################################
4             # Copyright (C) 2021 Asher Gordon #
5             # #
6             # This program is free software: you can redistribute it and/or #
7             # modify it under the terms of the GNU General Public License as #
8             # published by the Free Software Foundation, either version 3 of #
9             # the License, or (at your option) any later version. #
10             # #
11             # This program is distributed in the hope that it will be useful, #
12             # but WITHOUT ANY WARRANTY; without even the implied warranty of #
13             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU #
14             # General Public License for more details. #
15             # #
16             # You should have received a copy of the GNU General Public License #
17             # along with this program. If not, see #
18             # . #
19             ######################################################################
20              
21             package Text::Wrap::OO;
22             $Text::Wrap::OO::VERSION = '0.002';
23             #pod =head1 SYNOPSIS
24             #pod
25             #pod use Text::Wrap::OO;
26             #pod
27             #pod my $wrapper = Text::Wrap::OO->new(init_tab => "\t");
28             #pod $wrapper->columns(70);
29             #pod my $wrapped = $wrapper->wrap($text);
30             #pod my $filled = $wrapper->fill($text);
31             #pod
32             #pod =head1 DESCRIPTION
33             #pod
34             #pod Text::Wrap::OO is an object oriented wrapper to the
35             #pod L module.
36             #pod
37             #pod L is useful for formatting text, and it is
38             #pod customizable, but it has a drawback: The configuration options are set
39             #pod using global package variables. This means that if a module configures
40             #pod L, it can interfere with other modules that use
41             #pod L. Indeed, L
42             #pod documentation|Text::Wrap> itself warns against setting these
43             #pod variables, or if you must, to Cize them first. While this
44             #pod works, it can become cumbersome, and it still does not protect your
45             #pod module against other modules messing with L
46             #pod global variables.
47             #pod
48             #pod That's where Text::Wrap::OO comes in. Text::Wrap::OO provides an
49             #pod object oriented interface to L. The
50             #pod L global variables are automatically localized,
51             #pod so you need not worry about that. The defaults are always the same
52             #pod (unless you use the C attribute; see ATTRIBUTES) for each new
53             #pod object, so you don't need to worry about other modules messing with
54             #pod the settings either.
55             #pod
56             #pod A Text::Wrap::OO object has several attributes that can either be
57             #pod passed to the constructor (discussed later), or through accessor
58             #pod methods. The accessors are methods with the same name as the
59             #pod attributes they access, and can either be called with no arguments to
60             #pod get the value of the attribute, or with one argument to set the value
61             #pod of the attribute.
62             #pod
63             #pod Two other types of attribute-related methods are provided as well. For
64             #pod an attribute I, the C> and C> methods
65             #pod are available. C> will return true if the attribute
66             #pod I is set, and C> will unset I, as though it
67             #pod had never been set. Note that if an attribute is unset, the accessor
68             #pod will return the default value of the attribute, so
69             #pod C<< $object->clear_I >> is I the same thing as
70             #pod C<< $object->I(undef) >>.
71             #pod
72             #pod If you have a very old version of L which does
73             #pod not support a certain configuration variable, the corresponding
74             #pod attribute in a Text::Wrap::OO object will warn if you try to set it,
75             #pod and have no effect. You can turn off these warnings by setting the
76             #pod C attribute to a false value (see the documentation for the
77             #pod C attribute).
78             #pod
79             #pod =cut
80              
81 1     1   1355 use v5.18.0;
  1         9  
82 1     1   6 use strict;
  1         2  
  1         20  
83 1     1   5 use warnings;
  1         2  
  1         39  
84 1     1   7 use feature 'lexical_subs';
  1         2  
  1         79  
85 1     1   7 no warnings 'experimental::lexical_subs';
  1         10  
  1         42  
86 1     1   13 use Carp;
  1         2  
  1         103  
87 1     1   6 use List::Util 1.33 qw(any first pairs pairkeys);
  1         16  
  1         74  
88 1     1   632 use Module::Runtime qw(require_module);
  1         1825  
  1         5  
89 1     1   626 use Text::Wrap ();
  1         2903  
  1         41  
90 1     1   624 use Types::Standard qw(Maybe Enum Bool Str RegexpRef ArrayRef);
  1         82546  
  1         24  
91 1     1   2152 use Types::Common::Numeric qw(PositiveInt);
  1         12990  
  1         8  
92              
93             # It is important that we call namespace::autoclean->import at runtime
94             # rather than compile time so that eval()'d subs can still use
95             # imported names.
96             require namespace::autoclean;
97             namespace::autoclean->import(-also => 'subname');
98              
99             my $can_overflow = eval { Text::Wrap->VERSION(2001.0131); 1 };
100              
101             BEGIN {
102             # Find a suitable subroutine for setting a subroutine's name.
103 1     1   646 my $subname;
104 1         4 foreach (qw(Sub::Util::set_subname Sub::Name::subname)) {
105 1         8 my ($provider, $name) = (/^(.+)::/, $_);
106 1 50       2 next unless eval { require_module $provider; 1 };
  1         6  
  1         66  
107 1         7 $subname = \&$name;
108 1         2 last;
109             }
110 1   50     1442 *subname = $subname // sub { $_[1] };
  0         0  
111             }
112              
113             # Attribute definitions.
114             my %categories = (
115             opts => [
116              
117             #pod =attr inherit
118             #pod
119             #pod If this is true (default is false), attributes that correspond to
120             #pod L variables will use the value of the
121             #pod corresponding L variables if the attributes are
122             #pod not set. So, for example, if in object C<$object> C is true
123             #pod and C has never been set (or has been cleared with
124             #pod C<< $object->clear_columns >>), then C<< $object->columns >> will return
125             #pod the value of C<$Text::Wrap::columns> rather than the default for that
126             #pod attribute.
127             #pod
128             #pod C can also be an array reference, containing the names of
129             #pod attributes to inherit. Then, only the specified attributes will be
130             #pod inherited and nothing else.
131             #pod
132             #pod This is a powerful feature, and one that should be used sparingly. One
133             #pod situation in which you might want to use it is if you're writing a
134             #pod subroutine in which you I the values of the
135             #pod L variables to be inherited. For example:
136             #pod
137             #pod sub my_wrap {
138             #pod my $wrapper = Text::Wrap::OO->new(
139             #pod inherit => [qw(columns huge)],
140             #pod init_tab => "\t",
141             #pod tabstop => 4,
142             #pod );
143             #pod return $wrapper->wrap(@_);
144             #pod }
145             #pod
146             #pod sub process_text {
147             #pod my ($stuff, $text) = @_;
148             #pod # ... do stuff with $text ...
149             #pod return my_wrap $text;
150             #pod }
151             #pod
152             #pod # Later, possibly in another module:
153             #pod
154             #pod local $Text::Wrap::columns = 60;
155             #pod local $Text::Wrap::huge = 'overflow';
156             #pod my $processed_text = process_text $stuff, $text;
157             #pod
158             #pod Note that if any of the inherited variables have invalid values (e.g.,
159             #pod a non-numeric string for C<$Text::Wrap::columns>), then a warning will
160             #pod be emitted and the default value for the attribute will be used
161             #pod instead.
162             #pod
163             #pod =cut
164              
165             inherit => {
166             # 'isa' is set later.
167             default => 0,
168             },
169              
170             #pod =attr warn
171             #pod
172             #pod If this is true (the default), then whenever you try to set an
173             #pod attribute corresponding to an unsupported L
174             #pod variable, a warning will be emitted. A warning is also emitted if you
175             #pod try to set the C attribute to an array reference containing
176             #pod the name of at least one unsupported L
177             #pod variable, or if you try to set the C attribute to C,
178             #pod but that's not supported.
179             #pod
180             #pod =cut
181              
182             warn => {
183             isa => Bool,
184             default => 1,
185             },
186             ],
187              
188             #pod =pod
189             #pod
190             #pod The following two attributes are passed to the first and second
191             #pod arguments respectively of C and
192             #pod C. See L for more info.
193             #pod
194             #pod =cut
195              
196             args => [
197              
198             #pod =attr init_tab
199             #pod
200             #pod String used to indent the first line. Default: empty string.
201             #pod
202             #pod =attr subseq_tab
203             #pod
204             #pod String used to indent subsequent lines. Default: empty string.
205             #pod
206             #pod =cut
207              
208             [qw(init_tab subseq_tab)] => {
209             isa => Str,
210             default => '',
211             },
212             ],
213              
214             #pod =pod
215             #pod
216             #pod The following attributes correspond to the L
217             #pod global variables of the same name. So, for example, the C
218             #pod attribute corresponds to the C<$Text::Wrap::columns> variable. See
219             #pod L for more info.
220             #pod
221             #pod =cut
222              
223             vars => [
224              
225             #pod =attr columns
226             #pod
227             #pod The number of columns to wrap to. Must be a positive integer. Default:
228             #pod C<76>.
229             #pod
230             #pod =cut
231              
232             columns => {
233             isa => PositiveInt,
234             default => 76,
235             },
236              
237             #pod =attr break
238             #pod
239             #pod Regexp to match word terminators. Can either be a string or a
240             #pod pre-compiled regexp (e.g. C). Default: C<(?=\s)\X>.
241             #pod
242             #pod =cut
243              
244             break => {
245             isa => Str|RegexpRef,
246             default => '(?=\s)\X',
247             },
248              
249             #pod =attr huge
250             #pod
251             #pod Behavior when words longer than C are encountered. Can either
252             #pod be C, C, or C. Default: C.
253             #pod
254             #pod =cut
255              
256             huge => {
257             isa => Enum[qw(wrap die overflow)],
258             default => 'wrap',
259             },
260              
261             #pod =attr unexpand
262             #pod
263             #pod Whether to turn spaces into tabs in the returned text. Default: C<1>.
264             #pod
265             #pod =cut
266              
267             unexpand => {
268             isa => Bool,
269             default => 1,
270             },
271              
272             #pod =attr tabstop
273             #pod
274             #pod Length of tabstops. Must be a positive integer. Default: C<8>.
275             #pod
276             #pod =cut
277              
278             tabstop => {
279             isa => PositiveInt,
280             default => 8,
281             },
282              
283             #pod =attr separator
284             #pod
285             #pod Line separator. Default: C<\n>.
286             #pod
287             #pod =cut
288              
289             separator => {
290             isa => Str,
291             default => "\n",
292             },
293              
294             #pod =attr separator2
295             #pod
296             #pod If defined, what to add new line breaks with while preserving existing
297             #pod newlines. Default: C.
298             #pod
299             #pod =cut
300              
301             separator2 => {
302             isa => Maybe[Str],
303             },
304             ],
305             );
306              
307             # Expand multiple attributes specified as an array ref.
308             foreach my $attrs (values %categories) {
309             my @attrs;
310             foreach (pairs @$attrs) {
311             my ($names, $spec) = @$_;
312             push @attrs, map { $_ => $spec }
313             ref $names eq 'ARRAY' ? @$names : $names;
314             }
315             @$attrs = @attrs;
316             }
317              
318             # Get a hash of attributes and set the values of %categories to just
319             # the names of the attributes.
320             my %attributes = map @$_, values %categories;
321             @$_ = pairkeys @$_ foreach values %categories;
322              
323             # Now that we have all the attributes defined, we can set 'isa' for
324             # the 'inherit' attribute.
325             $attributes{inherit}{isa} = Bool|ArrayRef[Enum[@{$categories{vars}}]];
326              
327             # Make sure that each attribute which coerces has a type coercion.
328             while (my ($attr, $spec) = each %attributes) {
329             die "Attribute '$attr' can coerce, but does not have a coercion"
330             if $spec->{coerce} &&
331             ! (defined $spec->{isa} && $spec->{isa}->has_coercion);
332             }
333              
334             # Set attributes for $self, croaking on invalid attributes.
335             my $set_attrs = sub {
336             my ($self, $attrs, $name) = @_;
337             while (my ($attr, $value) = each %$attrs) {
338             croak "Invalid attribute passed to $name: '$attr'"
339             unless exists $attributes{$attr};
340             $self->$attr($value);
341             }
342             };
343              
344             #pod =method new
345             #pod
346             #pod $obj = Text::Wrap::OO->new(\%params|%params);
347             #pod
348             #pod Return a new Text::Wrap::OO object. The parameters may be passed as a
349             #pod hash reference, or as a hash. Parameters can be used to set the
350             #pod attributes as described above. Passing attributes as parameters to the
351             #pod constructor is exactly equivalent to using the accessors to set the
352             #pod attributes after creating the object.
353             #pod
354             #pod =cut
355              
356             sub new {
357 22     22 1 16513 my $class = shift;
358 22         39 my $params;
359 22 100       62 if (ref $_[0] eq 'HASH') {
360 5         11 $params = shift;
361 5 100       144 carp 'Too many arguments passed to constructor' if @_;
362             }
363             else {
364 17 100       60 if (@_ % 2) {
365 1         108 carp 'Odd number of elements passed to constructor';
366 1         9 push @_, undef;
367             }
368 17         43 $params = { @_ };
369             }
370              
371 22         93 my $self = bless {}, $class;
372 22         69 $self->$set_attrs($params, 'constructor');
373 20         75 return $self;
374             }
375              
376             # Perform type checking and coercions on $$value, setting it to the
377             # possibly coerced value. Returns undef on success or an error string
378             # on error.
379             my sub type_check {
380 110     110   160 my $attr = shift;
381 110         165 my $value = \shift;
382              
383 110         139 my $spec;
384 110 100       225 if (ref $attr eq '') {
385 46         83 $spec = $attributes{$attr};
386             }
387             else {
388 64         94 $spec = $attr;
389 64         85 undef $attr;
390             }
391              
392 110         183 my $type = $spec->{isa};
393 110 50       202 return unless defined $type;
394 110 50       199 $$value = $type->assert_coerce($$value) if $spec->{coerce};
395 110         293 my $err = $type->validate($$value);
396 110 100       4404 return unless defined $err;
397              
398 5 100       19 $err .= " (in attribute '$attr')" if defined $attr;
399 5         66 return $err;
400             }
401              
402             # Perform type checking on $value, returning the possibly coerced
403             # value. Croaks on error.
404             my sub type_assert {
405 46     46   90 my ($attr, $value) = @_;
406 46         89 my $err = type_check $attr, $value;
407 46 100       286 croak $err if defined $err;
408 44         827 return $value;
409             }
410              
411             my @unsupp_vars = grep ! exists $Text::Wrap::{$_},
412             @{$categories{vars}};
413              
414             # Build a new accessor for $attr, inheriting from $Text::Wrap::$attr
415             # if $category can inherit.
416             my sub build_accessor {
417             my ($category, $attr) = @_;
418             my $is_var = $category eq 'vars';
419             my $valid_var = ! $is_var || exists $Text::Wrap::{$attr};
420             my $spec = $attributes{$attr};
421             my $default = $spec->{default};
422             my $default_str = defined $default ? "'$default'" : 'undef';
423             my $inherit_var = "\$Text::Wrap::$attr";
424              
425             my $code = q[
426             my $self = shift;
427              
428             # Set the value if args were given.
429             if (@_) {
430             my $value = type_assert $attr, $_[0];
431             ];
432             my $warning = ! $valid_var ? q{
433             carp "The '\$Text::Wrap::$attr' variable is not supported " .
434             'on your version of Text::Wrap and will be ignored';
435             } : $attr eq 'inherit' ? q{
436             # Warn if any variables are unsupported.
437             my @vars = ref $value eq 'ARRAY' ?
438             grep ! exists $Text::Wrap::{$_}, @$value : @unsupp_vars;
439             if (@vars) {
440             my ($s, $are) = @vars == 1 ? ('', 'is') : qw(s are);
441             my $vars = join ', ', map "\$Text::Wrap::$_", @vars;
442             carp "The $vars variable$s $are not supported on your " .
443             'verison of Text::Wrap and cannot be inherited';
444             }
445             } : $attr eq 'huge' && ! $can_overflow ? q{
446             if ($value eq 'overflow') {
447             carp "The 'overflow' value for '$attr' is not " .
448             'supported on your version of Text::Wrap; ' .
449             q(falling back to 'wrap');
450             $value = 'wrap';
451             }
452             } : undef;
453             $code .= "if (\$self->warn) { $warning }" if defined $warning;
454             $code .= q[
455             return $self->{$attr} = $value;
456             }
457              
458             # Return the value of the attribute if any.
459             return $self->{$attr} if exists $self->{$attr};
460             ];
461             $is_var && $valid_var and $code .= q[
462             # Check if we can inherit this attribute.
463             my $inherit = $self->inherit;
464             $inherit = any { $_ eq $attr } @$inherit
465             if ref $inherit eq 'ARRAY';
466              
467             # Return the inherited value if we are inheriting.
468             if ($inherit) {
469             my $value = ]."$inherit_var;".q[
470              
471             my $err = type_check $spec, $value;
472             return $value unless defined $err;
473              
474             carp "Invalid value for $inherit_var: $err; " .
475             "falling back to default ($default_str)";
476              
477             # Fall back to default.
478             }
479             ];
480             $code .= q{
481             # Return the default.
482             return $default;
483             };
484              
485 7 50   7 1 19 eval "sub { $code }" or die;
  7 50   26 1 18  
  7 100   37 1 17  
  7 50   26 1 20  
  7 100   192 1 19  
  11 100   34 1 27  
  11 100   42 1 28  
  26 100   51 1 56  
  26 100   34 1 62  
  0 50   26 1 0  
  0 50   26 1 0  
  26 50   10   57  
  26 100       440  
  26 100       99  
  26 100       61  
  7 100       14  
  7 0       20  
  7 50       135  
  0 50       0  
  19 100       324  
  37 100       138  
  37 100       85  
  11 100       33  
  9 50       55  
  26 50       256  
  14 100       243  
  14 50       70  
  14 100       40  
  14 100       23  
  14 100       37  
  14 100       233  
  2 50       192  
  2 100       163  
  26 100       56  
  26 100       56  
  0 50       0  
  0 50       0  
  26 100       59  
  26 50       437  
  26 100       87  
  26 50       56  
  7 50       23  
  7 100       17  
  7 50       116  
  1 100       86  
  20 50       430  
  192 50       451  
  192         377  
  10         33  
  10         184  
  10         47  
  10         29  
  0         0  
  0         0  
  0         0  
  10         73  
  182         2134  
  68         1121  
  34         108  
  34         78  
  8         20  
  8         41  
  26         256  
  14         251  
  42         97  
  42         94  
  0         0  
  0         0  
  42         94  
  42         741  
  42         145  
  42         92  
  11         21  
  11         24  
  11         196  
  0         0  
  31         504  
  51         299  
  51         113  
  9         26  
  9         54  
  42         443  
  22         377  
  22         97  
  22         57  
  11         19  
  11         23  
  11         207  
  0         0  
  11         199  
  34         108  
  34         73  
  8         20  
  8         60  
  26         90  
  14         55  
  26         57  
  26         57  
  0         0  
  0         0  
  26         55  
  26         424  
  26         88  
  26         58  
  7         10  
  7         19  
  7         128  
  0         0  
  19         321  
  26         55  
  26         55  
  0         0  
  0         0  
  26         64  
  26         432  
  26         91  
  26         57  
  7         9  
  7         18  
  7         131  
  0         0  
  19         322  
  10         22  
  10         29  
  0         0  
  0         0  
  10         24  
  10         176  
486             }
487              
488             # Install the accessors.
489             while (my ($category, $attrs) = each %categories) {
490             foreach my $attr (@$attrs) {
491             my @methods = (
492             '' => (build_accessor $category, $attr),
493 0     0 0 0 has => sub { exists $_[0]->{$attr} },
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
494 0     0 0 0 clear => sub { delete $_[0]->{$attr} },
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
        0 0    
495             );
496              
497             foreach (pairs @methods) {
498             my ($subname, $code) = @$_;
499             $subname .= '_' unless $subname eq '';
500             $subname .= $attr;
501             subname $subname => $code;
502 1     1   9 no strict 'refs';
  1         2  
  1         412  
503             *$subname = $code;
504             }
505             }
506             }
507              
508             #pod =method wrap
509             #pod
510             #pod =method fill
511             #pod
512             #pod $wrapped = $obj->wrap(@text);
513             #pod $filled = $obj->fill(@text);
514             #pod
515             #pod These methods correspond to the C and
516             #pod C subroutines respectively. C<@text> is passed
517             #pod directly to the corresponding L subroutine,
518             #pod which joins them into a string, inserting spaces between the elements
519             #pod if they don't already exist.
520             #pod
521             #pod In scalar context, these methods return the wrapped text as a single
522             #pod string, like their L counterparts. However, in
523             #pod list context, a list of lines will be returned, split using the
524             #pod C and (if defined) C attributes (these are not
525             #pod regexps). Note that trailing separators will cause trailing empty
526             #pod strings to be returned in the list. Also note that any appearance of
527             #pod C or C already occurring in the input text will
528             #pod also be split on, not just the separators added by these methods. If
529             #pod you require more complicated processing, call these methods in scalar
530             #pod context and perform the splitting yourself.
531             #pod
532             #pod If @text is empty, these methods will return an empty list in list
533             #pod context, or an empty string in scalar context.
534             #pod
535             #pod In particular, note that C<< push @list, $object->wrap(@text) >> is
536             #pod not analogous to C. If
537             #pod you want to push a single item (the wrapped text) onto C<@list>, use
538             #pod C<< push @list, scalar $object->wrap(@text) >> instead.
539             #pod
540             #pod =cut
541              
542             my @methods = qw(wrap fill);
543              
544             # Localize Text::Wrap global variables with the values in $self.
545             my $localize_config = join ';',
546             map "local \$Text::Wrap::$_ = \$self->$_",
547             grep exists $Text::Wrap::{$_}, @{$categories{vars}};
548              
549             my @arg_keys = @{$categories{args}};
550              
551             my $separator = do {
552             my @seps = grep exists $Text::Wrap::{$_},
553             qw(separator2 separator);
554             @seps ? qq{
555             do {
556             my \$sep = first { defined } map \$self->\$_, qw(@seps);
557             defined \$sep or die 'No separator defined';
558             \$sep;
559             }
560             } : '"\n"';
561             };
562              
563             # Build a method $method, which calls Text::Wrap::$method as it's
564             # backend.
565             my sub build_method {
566             my ($method) = @_;
567              
568             exists $Text::Wrap::{$method} or return sub {
569             croak "The '$method' subroutine is not " .
570             'supported on your version of Text::Wrap';
571             };
572              
573             my $code = qq{
574             my \$self = shift;
575              
576             # Return nothing if we have no arguments.
577             return wantarray ? () : '' unless \@_;
578              
579             $localize_config;
580             my \$text = Text::Wrap::$method
581             ((map \$self->\$_, \@arg_keys), \@_);
582             return \$text unless wantarray;
583             return split $separator, \$text, -1;
584             };
585              
586 3 0   3 1 10 eval "sub { $code }" or die;
  12 50   18 1 30  
  18 100   8   301  
  18 50       49  
  18 0       318  
  18 50       312  
  18 100       342  
  18 50       312  
  18         311  
  18         341  
  18         310  
  18         333  
  18         29023  
  9         18  
  9         212  
  9         35  
  9         194  
  8         174  
  8         22  
  8         143  
  8         155  
  8         148  
  8         148  
  8         140  
  8         137  
  8         137  
  8         149  
  8         11961  
  3         6  
  3         73  
  3         12  
  3         66  
587             }
588              
589             # Install the methods.
590             foreach my $method (@methods) {
591             my $code = subname $method => build_method $method;
592 1     1   9 no strict 'refs';
  1         2  
  1         139  
593             *$method = $code;
594             }
595              
596             #pod =head1 SEE ALSO
597             #pod
598             #pod =for :list
599             #pod * L
600             #pod * L
601             #pod
602             #pod =head1 ACKNOWLEDGEMENTS
603             #pod
604             #pod Text::Wrap::OO relies on L for its main
605             #pod functionality, by David Muir Sharnoff and others. See
606             #pod L.
607             #pod
608             #pod =cut
609              
610             1;
611              
612             __END__