Acorn User 10/AU_CD10.iso/Updates/Perl/Non-RPC/!Perl/riscos/Text/DDF.pm

Text File | 1998-07-12 | 11KB | 595 lines

package Text::DDF;

require Exporter;
require 5.003;

$VERSION = 0.01;
@ISA = Exporter;
@EXPORT = qw(&ddfencode);
@EXPORT_OK = qw($strict_7bit);

$strict_7bit = 0;

sub ddfencode {
    foreach (@_)
    {
    s/\{/\{\\123\}/g;
    }
    if( $strict_7bit )
    {
    foreach (@_)
    {
        s/[\200-\377]/'{\\' . ord ($&) . '}'/ge;
    }
    }
    @_;
}

=head1 NAME

Text::DDF -- package for creating Impression Document Description Format

=head1 SYNOPSIS

    use Text::DDF

    print ddfencode(@text);


    use Text::DDF qw(ddfencode $strict_7bit);

    $strict_7bit = 1;
    ddfencode(@text);

    $index = new Text::DDF::Style 'Index', qw (index on);
    print $index->StyleWrap( @text );

=head1 DESCRIPTION

B<Text::DDF> provides subroutines and classes for creating files in Impression
B<D>ocument B<D>escription B<F>ormat.

C<Text::DDF::ddfencode> converts the array to C<DDF>, converting all
instances of 'C<{>' to 'C<{\123}>'. If C<Text::DDF::strict_7bit> is true,
it will also convert top-bit-set characters to 'C<{\###}>' notation.

C<Text::DDF::ddfencode> modifies the array passed, and for ease of use
additionally returns the array that it converted.

=head2 Effects and Styles

C<Text::DDF> provides classes for manipulating effects and styles -
C<Text::DDF::Effect>, C<Text::DDF::Justify>, C<Text::DDF::Style>. The overloaded
interface hides the differences in the DDF syntax used to turn styles and
effects on and off.

=head2 Common methods

=over 4

=item new <name> ...

Declare a style/effect with this name.

    $bold = new Text::DDF::Effect 'bold';
    $centre = new Text::DDF::Justify 'centre';
    $normal = new Text::DDF::Style 'Normal', qw(
      font Trinity.Medium
      fontsize 12pt );

Arguments after the style name are passed to the C<Add> method

    $no_op = new Text::DDF::Effect;

defines an empty effect

=item StyleOn

=item StyleOff

Return the C<DDF> instruction to turn the style/effect on/off.

=item StyleWrap

Return the C<DDF> turn the style/effect on, the verbatim text, the DDF to
turn the style/effect off. In array context returns an array:

    (
     StyleOn(),
     @_,
     StyleOf()
    )

In scalar context this array is concatenated

=item Define()

Returns the C<DDF> needed to defined the style/effect. Returns an empty string
for an effect, so that a mixed array of effects and styles can be C<Define>d
safely.

=item Copy <newname>

Returns a new style/effect clone. (with the same class as its parent.)

=item Print

Returns a formatted definition of the style/effect. This is mostly of use to the
C<Define> method.

In array context effects return an empty array, whereas styles return an array
of lines.

In scalar context styles return text of the form:

    style  "Normal";
     font Trinity.Medium;
     fontsize 12pt;

effects return:
    effect bold;

B<NB> scalars are terminated by "C<\n>"

=back

=head2 Style Methods

=over 4

=item Add

Takes pairs of C<attribute, value> and adds them to the style definition.

    $verbatim->Add( qw(spacebelow 0pt) );

You can use C<AddTabs> and C<AddTabComma> to add tabs, but the C<Add> method
will spot lines of the form

    Add( 'tabs', 'r18pt 24pt' );

and call C<AddTabsComma>.

=item AddTabs

Takes an array of tabs, and adds them to the style's array of tabs.

Tabs are strings such as

    r18pt
    25.4mm
    c4pi

The available prefixes are

=over 2

=item l

Left justify tab (the default if no prefix)

=item c

Centre justify tab

=item r

Right justify tab

=item d

Decimal tab

=item v

Vertical rule off

=back

    $itemlist->AddTabs( qw( r18pt 24pt 72pt 144pt 216pt 288pt 360pt 432pt 504pt ) );

=item AddTabsComma

Adds a comma separated list of tabs. Literally:

    sub AddTabsComma {
    my $self = shift;
    $self->AddTabs( split (/,/, $_[0]) );
    }

=item Get <attribute> ...

Returns an array of values corresponding to the array of attributes
passed

=item Delete <attribute> ...

Delete values corresponding to the array of attributes passed

=item GetTabs

In array context returns the sorted array of tabs in the format

    right 18pt
    centre 3pi
     25.5mm

In scalar context joins the list with commas

    right 18pt,centre 3pi, 25.5mm

=item DeleteTabs

Not implemented yet.

=item PrintTabs

In array context returns the sorted array of tabs in the format

    right 18pt
    centre 3pi
     25.5mm

In scalar context joins the list with commas and prefixes 'tabs'

    tabs right 18pt,centre 3pi, 25.5mm

or returns '' if there are no tabs defined.

=back

=head1 BUGS

=head2 Shortcomings of Impression's DDF interpreter

=over 4

=item *

DDF effects don't nest, whereas styles do.

    {bold on}Hello {bold on}W{bold}orld!{bold}

    {"bold" on}Hello {"bold" on}W{"bold"}orld!{"bold"}

produce

B<Hello W>orld!

B<Hello World!>

respectively if C<"bold"> is a style with the C<bold> attribute.

=item *

Even in Impression 4.11 the DDF exporter can't cope with style names
containing C<"> characters. Text::DDF::Style makes no checks about
the validity of characters in the style name.

=item *

There's no way to C<{keepregion}> two adjacent regions.

    {keepregion on}Pugh, Pugh, Barney McGrew,
    Cuthbert, Dibble, Grub
    {keepregion}{keepregion on}Time files by when you're the driver of a train,
    and you ride on the footplate there and back again
    {keepregion}

B<won't> allow a breaks between the two regions.

    {keepregion on}Pugh, Pugh, Barney McGrew,
    Cuthbert, Dibble, Grub{keepregion}
    {keepregion on}Time files by when you're the driver of a train,
    and you ride on the footplate there and back again
    {keepregion}

B<will> allow a break between I<Pugh, Pugh, Barney McGrew,> and
I<Cuthbert, Dibble, Grub>.

=back

=head2 Shortcomings of this package

You can't (yet) merge styles.

You can't (yet) merge effects into styles. (This would require a hash/function
to map effect names into style attributes).


=head1 AUTHOR

Nicholas Clark <F<[e-mail]>>

=cut

#    Ruler ISA Effect
#    Style ISA Ruler
# Internal keys start __

################################################################################
package Text::DDF::Effect;

use strict;
use vars qw($VERSION);

$VERSION = 0.01;

# Declare an effect.
sub new {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};
    my $name  = shift;

    $name = '' unless defined $name;

    $self->{'__NAME'} = $name;
    bless ($self, $class);
}

# Turn the effect/style on
#
# DDF Syntax differs
#
# {bold on}    turns on the effect 'bold'
# {"bold" on}    turns on the style "bold" (which isn't the same thing)
#
# But you don't need to know this with an OO Interface. 8-)

sub StyleOn {
    my $self = shift;

    return $self->{'__NAME'} ? "{$self->{'__NAME'} on}" : '';
}

sub StyleOff {
    my $self = shift;

    return $self->{'__NAME'} ? "{$self->{'__NAME'}}" : '';
}


sub StyleWrap {
    my $self = shift;

    if( wantarray )
    {
    return ( $self->StyleOn(), @_, $self->StyleOff() );
    }
    else
    {
    return ( $self->StyleOn() . join( '', @_) . $self->StyleOff() );
    }
}

sub Print {
    return () if( wantarray );

    my $self = shift;
    return $self->{'__NAME'} ? "effect $self->{'__NAME'};\n" : '';
}

sub Define {
    '';        # Effects don't need defining.
}

sub Copy {
    my $self = shift;
    my $clone = {%$self};
    bless ($clone, ref($self));
    $clone->{'__NAME'} = $_[0] if defined $_[0];
    $clone;
}

################################################################################
package Text::DDF::Justify;

use strict;
use vars qw($VERSION);

$VERSION = 0.01;

# Declare a justification effect. These differ only in how they are applied

sub StyleOn {
    my $self = shift;

    return "{justify $self->{'__NAME'}}";
}
sub StyleOff {
    return '{justify}';
}

################################################################################
package Text::DDF::Ruler;

use strict;
use vars qw($VERSION @ISA %tabs %special);


@ISA = 'Text::DDF::Effect';
$VERSION = 0.01;

use Carp;
use Units;

%tabs = ( l => '', r => 'right', c => 'centre', d => 'decimal', v => 'vertrule' );

%special = (    'tabs' => [\&AddTabsComma, \&GetTabs, sub {delete shift->{'__TABS'}}] );

sub quote ($) {
    # Will get improved to deal with style names with embedded "
    return "\"$_[0]\"";
}

sub __new ($;) {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};
    $self->{'__NAME'} = shift;
    bless ($self, $class);

    $self->Add( @_ );
}

sub new ($;) {
    push @_, 'effectruler', 'on';
    goto &__new
}

sub Name {
    my $self = shift;
    my $oldname = $self->{'__NAME'};
    $self->{'__NAME'} = $_[0] if( defined $_[0] );
    $oldname;
}

sub AddTabs {
    my $self = shift;
    foreach (@_)
    {
    my ($type,$pos) = m/^\s*([rlcdv]?)(.*)/io;
    $type = 'l' unless length $type;
    my $value = convert( 'mm', $pos );
    ${$self->{'__TABS'}}{$value} = "$type$pos";
    }
}

sub AddTabsComma {
    my $self = shift;
    $self->AddTabs( split (/,/, $_[0]) );
}

sub Add {
    my $self = shift;
    my ($class, $value);

    while( $class = shift, $value = shift, defined $value )
    {
    if( defined $special{$class} )
    {
        &{$special{$class}->[0]} ( $self, $value );
    }
    else
    {
        $self->{$class} = $value;
    }

    }

    $self;
}

sub GetTabs {
    my $self = shift;
    my @result;

    foreach (sort { $a <=> $b } keys %{$self->{'__TABS'}})
    {
    my ($type, $pos) = ${$self->{'__TABS'}}{$_} =~ /(.)(.*)/;
    push @result, "$tabs{$type} $pos";
    }

    return @result if wantarray;

    return join( ',', @result );
}

sub Get {
    my $self = shift;
    my (@result, $class);

    while( defined( $class = shift ) )
    {
    if( defined $special{$class} )
    {
        push @result, &{$special{$class}->[1]} ( $self );
    }
    else
    {
        push @result, $self->{$class};
    }
    }

    @result;
}

sub Delete {
    my $self = shift;
    my $class;

    while( defined( $class = shift ) )
    {
    if( defined $special{$class} )
    {
        &{$special{$class}->[2]} ( $self );
    }
    else
    {
        delete $self->{$class};
    }
    }
}

sub PrintTabs {
    my $self = shift;
    return $self->GetTabs() if wantarray;

    my $answer = scalar $self->GetTabs();
    return length( $answer ) ? "tabs $answer" : '';
}

sub Print {
    my $self = shift;
    my @result = ("style " . quote ($self->{'__NAME'}));
    my $tabs = scalar $self->PrintTabs();

    push @result, $tabs unless $tabs eq '';

    my ($key, $value);
    while (($key,$value) = each %$self) {
    push @result, "$key $value" unless $key =~ /^__/o;
    }

    return @result if( wantarray );

    return (join ";\n ", @result) . ";\n";
}

sub Define {
    my $self = shift;

    my $result = $self->Print;
    $result =~ s/;\s$//m;
    return "{\ndefine $result}";
}

sub StyleOn {
    my $self = shift;

    return '{' . quote ($self->{'__NAME'}) . ' on}';
}

sub StyleOff {
    my $self = shift;

    return '{' . quote ($self->{'__NAME'}) . ' off}';
}

################################################################################
package Text::DDF::Style;

use strict;
use vars qw($VERSION @ISA);

@ISA = 'Text::DDF::Ruler';
$VERSION = 0.03;


sub new ($;) {
    goto &Text::DDF::Ruler::__new
}

1;