home *** CD-ROM | disk | FTP | other *** search
/ Acorn User 10 / AU_CD10.iso / Updates / Perl / Non-RPC / !Perl / riscos / RISCOS / DrawFile / TextArea / Parser.pm
Text File  |  1998-07-31  |  28KB  |  918 lines
  1. package RISCOS::DrawFile::TextArea::Parser;
  2. use Carp;
  3.  
  4. use strict;
  5. use vars qw ($VERSION @ISA %parser $lax $mode);
  6. use RISCOS::Units qw(millipoint2draw draw2millipoint point2draw);
  7. require RISCOS::DrawFile::TextArea;
  8. require RISCOS::Font;
  9.  
  10. $VERSION = 0.02;
  11. @ISA = 'RISCOS::DrawFile::TextArea';
  12.  
  13. # Definately not threadable.
  14. $mode = '' unless defined $mode;
  15. # '' for native
  16. # 'D' for Draw emulation
  17. # '+' for DrawPlus emulation
  18. # 'F' for DrawFile module emulation
  19. # 'L' for Librarian emulation
  20.  
  21. sub new {
  22.     my $proto = shift;
  23.     my $class = ref($proto) || $proto;
  24.  
  25.     my $self = RISCOS::DrawFile::TextArea->new (@_);
  26.     $self = $self->[0] if ref ($self) eq 'ARRAY';
  27.  
  28.     bless ($self, $class);
  29.  
  30.     my $output = [];
  31. #    foreach (@{$self->Cols()}) {
  32. #     push @$output, scalar &RISCOS::DrawFile::Path::Rectangle($_, undef, [255, 0, 0]);
  33. #    }
  34.  
  35.     $self->{'__MODE'} = $mode;
  36.     $self->{'__ALIGN'} = 'L';
  37.     $self->{'__FONT'} = {};
  38.     $self->{'__PLEAD'} = $self->{'__LEAD'} = point2draw 10;
  39.     $self->StartY() if ($self->{'__MODE'} eq 'F');
  40.     # Bozo DrawFile module interprets the spec rather strictly and *always*
  41.     # starts the first line at \L10
  42.  
  43.  
  44.     $self->Margins (1, 1);
  45.     # $self->{'__STARTY'} is undefined, and read as __LEAD first time
  46.     # Oh, unless we're the Drawfile module in which case it is 10 points first
  47.     # time.
  48.  
  49.     my $text = \$self->{'__TEXT'};
  50.  
  51.     unless ($$text =~ s/^\\! 1\n//s or $lax) {
  52.     $$text =~ /^(.{1,5})/s;
  53.     warn "TextArea starts with '$1' not '\\! 1\n'";
  54.     }
  55.     $$text =~ tr/\t\n -\377//cd;    # Delete unrecognised control chars.
  56.  
  57.     my $current = $self->reset_block(undef, undef, undef);
  58.     my @line = $current;
  59.     my $seen_printing;
  60.     if ($self->{'__MODE'} eq 'L') {
  61.     # Some sort of cacky definition of a no-show.
  62.     # return ()
  63.     #  if $self->{'__FORE'} eq 'ÿÿÿÿ' and $self->{'__BACK'} eq 'ÿÿÿÿ';
  64.     $self->{'__FORE'} = "\0\0\0\0";
  65.     $self->{'__BACK'} = "\0ÿÿÿ";
  66.     }
  67.     #  0    action (default 0x118 - underline break, text vertical and
  68.     #        horizontal) shift
  69.     #        Not sure whether to believe this, as rechecking what differs
  70.     #        allows more sophisticated agglomeration if (say) UL is changed
  71.     #        to same thickness.
  72.     #  1    x offset from left margin (draw units)
  73.     #        undef means read left margin for first, or carry on using
  74.     #        previous entry width
  75.     #  2    y offset from previous x,y; (draw units)
  76.     #  3    width of this object (unjustified) (draw units)
  77.     #  4    font fore
  78.     #  5    font back
  79.     #  6    font object (name, width, height)
  80.     #  7    underline position
  81.     #  8    underline thickness
  82.     #  9    text
  83.     # 10    position (relative to left margin)
  84.     #        undef if it needs recalculating
  85.     # 11    position + width
  86.     # 12    number of spaces
  87.     while (length $$text) {
  88.     my ($action, $words, $para) = 0;
  89.     if ($$text =~ /^\\(.)/s) {
  90.         my $length = length $$text;
  91.         # print STDERR "$1\n";    # \ Command
  92.         if (defined (my $sub = $parser{$1})) {
  93.         ($action, $words) = &$sub ($self, $text);
  94.         if (length ($$text) == $length) {
  95.             $$text =~ /^(.*)/m;
  96.             die "Mangled command in '$1'";
  97.         }
  98.         } else {
  99.         $$text =~ /^(.*)/m;
  100.         die "Undefined command in '$1'";
  101.         }
  102.     } elsif ($$text =~ s/^(\n+)//s) {
  103.         $para = length ($1) - 1;
  104.         if ($$text =~ /^[\t ]/) {
  105.         # As far as Draw is concerned "\n\t" or "\n " *is* a single
  106.         # paragraph break
  107.         $para = 1 if not $para and $self->{'__MODE'} eq 'D';
  108.         # DrawFile module attempts to emulate Draw's bug whereby
  109.         # \n\t is treated as a paragraph break, but in the
  110.         # process intruduces its own. D'oh
  111.         $para++ if $self->{'__MODE'} eq 'F';
  112.         }
  113.         if ($para) {
  114.         # print "paragraph $para \n";
  115.         $action = 0x20000;
  116.         # Bleurgh. Draw breaks the spec.
  117.         $para = int ((2 + $para) / 2) if $self->{'__MODE'} eq 'D';
  118.         } else {
  119.         # print "Embedded newline\n";
  120.         # Ingore it as per spec if it is followed by space
  121.         $words = ($$text =~ /^[\t ]/) ? '' : ' ';
  122.         # DrawFile module eats final single newline
  123.         $words = '' if $$text eq '' and $self->{'__MODE'} eq 'F';
  124.         if (not $seen_printing and not $current->[6]) {
  125.             die "No font set before single newline encountered\n";
  126.         }
  127.         }
  128.     } else {
  129.         $$text =~ s/^([^\\\n]*)//s;
  130.         ($words = $1) =~ tr/\t/ /;
  131.         # Remove a single newline following text that ends with a space.
  132.         $$text =~ s/^\n(?![\n\t ])// if $words =~ / $/;
  133.     }
  134.     if (defined $words and length $words) {
  135.         if (not $seen_printing and not $current->[6]) {
  136.         carp "No font set before text '$words' encountered";
  137.         return ();
  138.         }
  139.         $seen_printing = 1;
  140.         $current->[3]    # Width
  141.           = millipoint2draw
  142.         $current->[6]->StringBBox($current->[9] .= $words)->[2];
  143.         # Increase the right bbox edge if it is already calculated.
  144.         # No bozo, you can't remove this
  145.         $current->[11] = $current->[10] + $current->[3]
  146.           if defined $current->[10];
  147.     }
  148.  
  149.     my $restore = 0;
  150.     if (!length $current->[9]) {
  151.         # $current points to an empty thing
  152.         pop @line;
  153.         $restore = 1;
  154.     }
  155.  
  156.     if (@line) {
  157.         WRAP: while (1) {
  158.         # We have text. Check how much overflows margins
  159.         # Hike off what we can if we overflow a line
  160.         my $which = 0;
  161.         # 1 hour later - don't let it auto-vivify
  162.         while (defined $line[$which]
  163.             and defined $line[$which]->[10]) {
  164.             $which++
  165.         }
  166.  
  167.         # This loop may run zero times
  168.         while (defined $line[$which]) {
  169.             # First see if we live at an absolute x offset
  170.             unless (defined ($line[$which]->[10]
  171.                      = $line[$which]->[1])) {
  172.             # First object is at left margin (ie offset zero from it)
  173.             # Rest are previous object offset + previous object width
  174.             # print STDERR "'$words' $which $line[$which-1]->[10]\n";
  175.             $line[$which]->[10] = $which ? ($line[$which-1]->[10]
  176.                              + $line[$which-1]->[3])
  177.                            : 0;
  178.             }
  179.  
  180.             $line[$which]->[11] = $line[$which]->[10]
  181.                         + $line[$which]->[3];
  182.             $which++;
  183.         }
  184.         # Right, everything has a position
  185.         my $width = $self->Width();
  186.         for ( $which = 0 ; $which < @line ; $which++ ) {
  187.             if ($line[$which]->[11] > $width) {
  188.             # Wrap time
  189.             my $victim = $line[$which];
  190.             # print "$victim->[11] > $width\n";
  191.             # print "Overflow with $which $victim->[10] "
  192.             #  ."'$victim->[9]'\n";
  193.             my ($split) =
  194.               $victim->[6]->Split($victim->[9], ' ', 0,
  195.             # Remaining width
  196.                 draw2millipoint $width - $victim->[10]);
  197.  
  198.             # OK, life gets messy here.
  199.             # Need to find the last space that fits in the column
  200.             # (if any).
  201.             # If $split is not '' then it's in $victim
  202.             # Otherwise seach back in the line until we hit the last
  203.             # space.
  204.             #
  205.             # Then need to run forward from the position of the
  206.             # space checking all positions of soft hyphens until
  207.             # we either find
  208.             # 1    another space [this cuts search of early]
  209.             # 2    a soft hyphen that doesn't fit
  210.             # 3    we run out of text
  211.             #    hangon - actually, that means that we hit the
  212.             #    end of $victim, as we know that $victim won't
  213.             #    all fit, so there is no way that $victim plus
  214.             #    some more stuff will.
  215.             #    hangon, I don't think that we can meet a space
  216.             #    until we are in $victim again.
  217.             #
  218.             # each time that we find a soft hyphen that fits record
  219.             # its position
  220.             #
  221.             # So we have variables:
  222.             # object containing last known space/soft hyphen
  223.             # $found
  224.             # offset of (start of) last known space/soft hypen
  225.             # $split
  226.             # flag ('-' for soft hyphen, '' for space)
  227.             # $flag
  228.             # object we are currently searching.
  229.             # $which
  230.             #
  231.             # soft hyphens are not marked known until we verify that
  232.             # they fit on the line
  233.             my ($length, $found);
  234.             if (length $split) {
  235.                 $found = $which;
  236.                 # print "Splitting on space '$split'\n";
  237.             } else {
  238.                 # OK, got to find that space
  239.                 while ($which) {
  240.                 if ($line[--$which]->[9] =~ /(.*) /) {
  241.                     $split = $1;
  242.                     $found = $which;
  243.                     last;
  244.                 }
  245.                 }
  246.             }
  247.             # Doubt this will really help until there are more
  248.             # than about 3 soft hyphens in one word.
  249.             # (Units in millipoints)
  250.             # my $remains = $width
  251.             #  -  $victim->[6]->CharBBox('-')->[2];
  252.  
  253.             # Now loop round the possible soft hypen positions
  254.             # If you are Draw or DrawPlus you let soft hyphens
  255.             # impinge into the right margin (but not go outside the
  256.             # column)
  257.  
  258.             # Skip stuff before first space
  259.             $length = length $split;
  260.             my ($offset, $flag) = (0, '');
  261.             OBJECTS: while (1) {
  262.                 # Assign to pos to start matching after prefix
  263.                 # (or to make damn sure we aren't confused later on
  264.                 # if this position happens to fail a soft hyphen
  265.                 # check and then we return here for a soft hyphen
  266.                 # check on the next line)
  267.                 pos $line[$which]->[9] = $length;
  268.                 while ($line[$which]->[9] =~ /\025-\n/sg) {
  269.                 last OBJECTS if ($width < (
  270.                   $line[$which]->[10] +    # Start coord
  271.                   millipoint2draw
  272.                   $line[$which]->[6]->StringBBox("$`-")->[2]));
  273.                 # Wah, it's loads of -> -> ->
  274.                 # get here if it doesn't overflow
  275.                 $split = $`;
  276.                 $flag = '-';
  277.                 $found = $which;
  278.                 # print "Found - in $found '$split'\n";
  279.                 }
  280.                 # Got back to the object we started at, and we know
  281.                 # for sure that it doesn't fit
  282.                 last if $line[$which] eq $victim;
  283.                 # OK, starting a new object, so there is no prefix
  284.                 # text to skip
  285.                 $length = 0;
  286.                 $which++;
  287.             }
  288.  
  289.             # OK.
  290.             # $found is undef if we really haven't been able to
  291.             # split anywhere. In that case split victim at any
  292.             # character
  293.             # otherwise
  294.             # $found is the index of the object to split
  295.             # $split is the text to strip from the front of it
  296.             # $flag = '-' if we're splitting on a soft hyphen:
  297.             #    add '-' to $split
  298.             #    strip soft hyphen from front of remainder
  299.             # else strip leading whitespace
  300.             if (defined $found) {
  301.                 # Fake it as if we'd terminated at this point in the
  302.                 # first place.
  303.                 $which = $found;
  304.                 $victim = $line[$which];
  305.                 $victim->[9] = substr ($victim->[9], length $split);
  306.                 if ($flag) {
  307.                 # Soft hyphen found
  308.                 $victim->[9] =~ s/^\025-\n//s;
  309.                 $split .= $flag;
  310.                 } else {
  311.                 $victim->[9] =~ s/^ *//s;
  312.                 }
  313.                 # print "'$split' '$victim->[9]'\n";
  314.             } else {
  315.                 die '!' unless $victim eq $line[$which];
  316.                 # Waah. Single word too long and must be split
  317.                 ($split)
  318.                    = $victim->[6]->Split($victim->[9], '', 0,
  319.                              draw2millipoint
  320.                                $width - $victim->[10]);
  321.                 unless (length $split) {
  322.                 $victim->[6] =~ /^([^ ]+)/;
  323.                 die 'First character of word \'' . $1 .
  324.                     '\' too wide for margins';
  325.                 }
  326.                 $victim->[9] = substr ($victim->[9], length $split);
  327.             }
  328.             # print "Loose '$split' keep '$victim->[9]'\n";
  329.             my @process;
  330.             if (length $victim->[9]) {
  331.                 # There is some text left
  332.                 $victim->[3] = millipoint2draw
  333.                    $victim->[6]->StringBBox($victim->[9])->[2];
  334.                 # print "Now $victim->[3]\n";
  335.                 # Remove all items up to item before the split item.
  336.                 @process = splice @line, 0, $which;
  337.                 # Copy the split item. The copy in @line has
  338.                 # the second half of the text and the correct
  339.                 # width
  340.                 # Our copy referenced via $vicitm can now be
  341.                 # ammended without affecting the details in @line
  342.                 $victim = [@$victim];
  343.             } else {
  344.                 # Remove all items including the "split" item, which
  345.                 # appears to have no printable characters after
  346.                 # split point.
  347.                 # I don't think that we should ever end up in here.
  348.                 # print "You aren't here with $which '$split' "
  349.                 #    ."'$victim->[9]' '$line[$which+1]->[9]'\n";
  350.                 # Wrong. \C255 0 0/swings \B0 255 0
  351.                 # splits on the space after swings. The space is
  352.                 # then eaten by the s///; above.
  353.                 # So we need to remove the empty last element, as it
  354.                 # is a reference to the same array as $victim.
  355.                 # (and hence when we assign to it (below) we'll be
  356.                 # writing to two places)
  357.                 @process = splice @line, 0, $which;
  358.                 shift @line;    # Remove this empty entry
  359.                 unless (@line or $restore) {
  360.                 # Make sure there will be at least one entry
  361.                 # in the line accumulator next time round
  362.                 @line = $current = $self->reset_block();
  363.                 # 0x800000 hack was here. It doesn't work :-)
  364.                 }
  365.             }
  366.             if (@line) {
  367.                 # However, if there was a vertical move, we have it
  368.                 # in our copy, so the original doesn't need it
  369.                 $line[0]->[2] = 0;
  370.                 # And the original is on a new line, so it can't be
  371.                 # appended to the previous text.
  372.                 $line[0]->[0] |= 0x101;
  373.             }
  374.  
  375.             # Remove all the calculated x positions on the remaining
  376.             # items, so that next time round the loop they get
  377.             # recalculated.
  378.             foreach (@line) {
  379.                 undef $_->[10];
  380.             }
  381.             # Copy the first half text into vicitm and write its
  382.             # width
  383.             $victim->[3] = millipoint2draw
  384.                $victim->[6]->StringBBox($victim->[9] = $split)->[2];
  385.             $victim->[11] = $victim->[10] + $victim->[3];
  386.             push @$output, &__doaline ($self, $self->{'__ALIGN'},
  387.                            @process, $victim);
  388.             $self->PendingMargins();
  389.             return $output
  390.               unless defined $self->LeadBy($self->{'__LEAD'});
  391.             redo WRAP;
  392.             }
  393.         }
  394.         last WRAP;
  395.         }
  396.     }
  397.     # warn "$restore $#line $current $line[$#line]";
  398.     # warn "$restore $#line $current $line[$#line]";
  399.     # Force final flush
  400.     $action |= 0x10000 unless length ($$text);
  401.  
  402.     if ($action) {
  403.         # Do it
  404.         # (unless we're being the DrawFile module and \A)
  405.         if ($action & 0x7F0000) {
  406.         # Line or paragraph
  407.         # printf "Flushing %8X:\n", $action;
  408.         # foreach my $chunk (@line) {
  409.         #    print "\t$chunk->[8]\n";
  410.         # }
  411.         # print "\n";
  412.  
  413.         if ((($action & 0x7F0000) == 0x40000)
  414.              and $self->{'__MODE'} eq 'F') {
  415.             $action = 0
  416.         } else {
  417.             # Why this not work?
  418. #            unless ($action & 0x40000 and not @line) {
  419.             unless ($action & 0x40000 and not $seen_printing) {
  420.             my $align = $self->{'__ALIGN'};
  421.             $align = 'L' if $align eq 'D';
  422.             push @$output, &__doaline ($self, $align, @line);
  423.             @line = ();
  424.             if ($action & 0x20000) {
  425.                 $self->LeadBy($self->{'__LEAD'}
  426.                       + $para * $self->{'__PLEAD'})
  427.             } else {
  428.                 $self->LeadBy($self->{'__LEAD'})
  429.             }
  430.             $action |= 0x101;
  431.             # Force text and underline breaks.
  432.             }
  433.         }
  434.         # warn 'Bailout' if $self->{'__BAILOUT'};
  435.         return $output if $self->{'__BAILOUT'};
  436.         if (defined $self->{'__PENDINGALIGN'}) {
  437.             $self->{'__ALIGN'} = $self->{'__PENDINGALIGN'};
  438.             delete $self->{'__PENDINGALIGN'};
  439.         }
  440.         }
  441.         if ($action & 0xFFFFFF) {
  442.         # Making a new array current
  443.         $restore = 1;
  444.         $current = $self->reset_block(($seen_printing ? $action
  445.                                   : undef),
  446.                           undef, undef, $current->[2]);
  447.         }
  448.     }
  449.     # Do the pending margins unless we have some printing text.
  450.     $self->PendingMargins() unless @line;
  451.     push @line, $current if $restore;
  452.     }
  453.     $output
  454. }
  455.  
  456.  
  457. # Self
  458. # Alignment
  459. # Array of things
  460. sub __doaline {
  461.     my $self = shift;
  462.     my $align = shift;
  463.     return () unless @_;
  464.     my ($left, $right) = ($self->StartX(), $self->EndX());
  465.     my ($extra, $x, $y) = (0, 0, $self->StartY());
  466.  
  467.     # Fake the margins to acchieve the desired alignment.
  468.     if ($align eq 'D') {
  469.     # $spaces = 0;
  470.     my $j_from = @_;    # Object number
  471.     my ($spaces, $width);
  472.  
  473.     while ($j_from) {
  474.         last if defined $_[--$j_from][1];
  475.     }
  476.     # $object >= 0
  477.     my @done = splice @_, 0, $j_from;
  478.     # @_ now contains only the objects that need justifying.
  479.     my $j_left = $left + ($_[0][1] || 0);
  480.  
  481.     @_ = (@done, map {
  482.         my $current = $_;
  483.         my $flag = $$current[0];
  484.         my $starty =  $$current[2];
  485.         my @list = ();
  486.         $$current[0] = 0x20;    # Text horizontal shift break
  487.         $$current[2] = 0;        # no vertical move
  488.         while (length $$current[9] and $$current[9] =~ s/^([^ ]*)//) {
  489.         my $bit = [@$current];
  490.         $$bit[9] = $1;
  491.         if ($$current[9] =~ s/^( +)//) {
  492.             # Find if there are any trailing spaces and if so append
  493.             # Write the space count for this object.
  494.             $spaces += $$bit[12] = length $1;
  495.             $$bit[9] .= $1;
  496.         }
  497.         if (length $$bit[9]) {
  498.             $width += $$bit[3]
  499.               = millipoint2draw $$bit[6]->StringBBox($$bit[9])->[2];
  500.             push @list, $bit
  501.         } else {
  502.             confess "Error with '$$current[9]' remaining";
  503.         }
  504.         }
  505.         $list[0][0] = $flag;    # Restore true flags for first object
  506.         $list[0][2] = $starty;    # Restore true y offset for first object
  507.         @list;
  508.     } @_);
  509.     # Spaces = 0 is equivalent to left justification.
  510.     # oops. that's what happens anyway :-)
  511.  
  512.     # $width gives right edge of last thing
  513.     $extra = (($right - $j_left - $width) / $spaces) if $spaces;
  514.     # Split extra space equally for each space, even if they are different
  515.     # font sizes.
  516.     # print "$spaces $extra\n" if defined $spaces;
  517.     } elsif ($align eq 'L') {
  518.     } elsif ($align eq 'R') {
  519.     # $width = $_[$#_]->[11];
  520.     $left = $right - $_[$#_]->[11];
  521.     } elsif ($align eq 'C') {
  522.     my $centre = ($left + $right) / 2;
  523.     my $width = $_[$#_]->[11];
  524.     $left = $centre - $width / 2;
  525.     $right = $centre + $width / 2;
  526.     } else {
  527.     confess "Unknown alignment code '$align'";
  528.     }
  529.  
  530.     my ($starty, $nextx, @output);
  531.     $starty = $y;
  532.     $nextx = 0;
  533.     my @text;
  534.     # start x, start y, length, colour, thickness
  535.     # length is left edge of next text object.
  536.     my @underline;
  537.  
  538.     foreach my $object (@_) {
  539.     $object->[9] =~ s/\025-\n//gs;    # Strip still-soft hyphens
  540.  
  541.     $x = defined ($object->[1]) ? $object->[1] : $nextx;
  542.  
  543.     if ($object->[0] & 255) {
  544.         # Break
  545.         if (@text) {
  546.         if (my $output = RISCOS::DrawFile::Text->new (\@text, 7)) {
  547.             push @output, ref ($output) eq 'ARRAY' ? @$output : $output;
  548.         }
  549.         }
  550.  
  551.         $y -= $object->[2];
  552.  
  553.         # fore, back, font, h, w, x, y, text, kern, r2l, trans
  554.         # colours already packed so pass a reference
  555.         @text = (\$object->[4], \$object->[5], $object->[6], undef, undef,
  556.              $left + $x, $y, $object->[9]);
  557.     } else {
  558.         $text[7] .= $object->[9];
  559.     }
  560.     $nextx = $x + $object->[3] + $extra * ($object->[12] || 0);
  561.     # x still holds start of this object
  562.     # nextx has x for next object (possibly corrected for justification
  563.     if ($object->[0] & 0xFF00) {
  564.         # Underline break
  565.         push @output, scalar RISCOS::DrawFile::Path->new (
  566.         # Move to the start, line to the width
  567.         [[[2, $underline[0], $underline[1]],
  568.           [8, $underline[2], $underline[1]]],
  569.         # Fill, line colours,  width
  570.          undef, $underline[3], $underline[4]]) if @underline;
  571.  
  572.         if ($object->[8]) {
  573.         # DrawPlus is just plain inconsistent here - change the zoom!
  574.         @underline = ($left + $x, $y + $object->[7] - $object->[8] / 2,
  575.                   $left + $nextx, \$object->[4], $object->[8]);
  576.         } else {
  577.         @underline = ();
  578.         }
  579.     }
  580.     elsif ($object->[8]) {
  581.         $underline[2] = $left + $nextx;
  582.     }
  583.     }
  584.     if (@text) {
  585.     if (my $output = RISCOS::DrawFile::Text->new (\@text, 7)) {
  586.         push @output, ref ($output) eq 'ARRAY' ? @$output : $output;
  587.     }
  588.     }
  589.     push @output, scalar RISCOS::DrawFile::Path->new (
  590.       [[[2, $underline[0], $underline[1]],
  591.        [8, $underline[2], $underline[1]]],
  592.     # Fill, line colours,  width
  593.       undef, $underline[3], $underline[4]]) if @underline;
  594.     $starty -= $y;
  595.     # Remove this for DrawPlus-like behaviour
  596.     $self->LeadBy($starty) if $starty and ($self->{'__MODE'} ne '+' or
  597.                        $self->{'__MODE'} ne 'F');
  598.  
  599.     @output
  600. }
  601.  
  602.  
  603. sub reset_block ($;$$$) {
  604.     my ($self, $action, $x, $y) = @_;
  605.     # $x = $self->{'__LEFTM'} unless (@_ > 1); Don't set this.
  606.  
  607.     $y = 0 unless defined $y;
  608.     if (defined ($self->{'__VERT'})) {
  609.     $y += $self->{'__VERT'};
  610.     undef $self->{'__VERT'};
  611.     }
  612.     $action = 0x118 unless defined $action;
  613.  
  614.     [$action, $x, $y, 0, $self->{'__FORE'}, $self->{'__BACK'},
  615.     $self->CurrentFont(), $self->{'__UPOS'}, $self->{'__UWIDTH'}, ''];
  616. }
  617.  
  618. sub CurrentColumn {
  619.     my $self = shift;
  620.     my $cc = \$self->{'__CURCOL'};
  621.     return $$cc if defined $$cc;
  622.     unless (defined ($$cc = $self->ShiftCols())) {
  623.     $self->{'__BAILOUT'} = 1;
  624.     } else {
  625.     $self->{'__STARTX'} = $$$cc[0] + $self->{'__LEFTM'}
  626.       if defined $self->{'__LEFTM'};
  627.     if (defined $self->{'__RIGHTM'}) {
  628.         $self->{'__ENDX'} = $$$cc[2] - $self->{'__RIGHTM'};
  629.         $self->{'__LINEWIDTH'} = $self->{'__ENDX'} - $self->{'__STARTX'}
  630.           if defined $self->{'__LEFTM'};
  631.     }
  632.     }
  633.     $$cc;
  634. }
  635. sub StartY {
  636.     my $self = shift;
  637.     if (defined $self->{'__CURCOL'}) {
  638.     my $y = $self->{'__STARTY'};
  639.     return $y if defined $y;
  640.     }
  641.     return undef unless defined (my $cc = $self->CurrentColumn());
  642.     $self->{'__STARTY'} = $cc->[3] - $self->{'__LEAD'};
  643. }
  644. sub PendingMargins() {
  645.     return unless $_[0]->{'__PENDINGM'};
  646.     $_[0]->Margins(@{$_[0]->{'__PENDINGM'}});
  647.     delete $_[0]->{'__PENDINGM'};
  648. }
  649. sub Margins ($$$) {
  650.     my ($self, $left, $right) = @_;
  651.     my $col = $self->CurrentColumn();
  652.     $self->{'__STARTX'} = $$col[0] + ($self->{'__LEFTM'} = point2draw $left);
  653.     $self->{'__ENDX'} = $$col[2] - ($self->{'__RIGHTM'} = point2draw $right);
  654.     $self->{'__LINEWIDTH'} = $self->{'__ENDX'} - $self->{'__STARTX'};
  655. }
  656. sub StartX ($) {
  657.     $_[0]->{'__STARTX'};
  658. }
  659. sub EndX ($) {
  660.     $_[0]->{'__ENDX'};
  661. }
  662. sub Width ($) {
  663.     $_[0]->{'__LINEWIDTH'}
  664. }
  665. sub LeadBy ($$) {
  666.     my ($self, $by) = @_;
  667.     return undef if $self->{'__BAILOUT'};
  668.     # This makes sure that __STARTY is initialised if a line break is found
  669.     # before any printing text
  670.     my $y = $self->{'__STARTY'} = $self->StartY() - $by;
  671.     return $y if ($y >= $self->CurrentColumn()->[1]);
  672.     # print "lead by $by drops off end\n";
  673.     undef $self->{'__CURCOL'};    # New column
  674.     $self->StartY();
  675. }
  676. sub CurrentFont {
  677.     my $self = shift;
  678.     my $font = $self->{'__FONT'}->{$self->{'__CURFONT'}}
  679.       if defined $self->{'__CURFONT'};
  680.     if (ref ($font) eq 'ARRAY') {
  681.     # Find the font now. Don't bother finding fonts that are declared but
  682.     # never used in the text area.
  683.     # Don't leave the font as an array to pass to string width because this
  684.     # will result in tons of calls to find and loose it for each call.
  685.     # Remember that the destructor looses this object correctly :-)
  686.     $font = RISCOS::Font->new(@$font);
  687.     unless ($font) {
  688.         warn $^E;
  689.         $font = RISCOS::Font->new('Trinity.Medium', 12);
  690.     }
  691.     $self->{'__FONT'}->{$self->{'__CURFONT'}} = $font if defined $font;
  692.     }
  693.     $font;
  694. }
  695.  
  696. # Pass in self, reference to scalar
  697. # 0x01000000    line format change (margins, centring, tabstops, leading)
  698. # 0x00800000    internal hack to force regeneration of block
  699. # 0x00040000    line break unless at start (or end) of line (\A)
  700. # 0x00020000    new paragraph
  701. # 0x00010000    forces line break (not new paragraph)
  702. # 0x00000100    underline break
  703. # 0x00000020    text horizontal shift break
  704. # 0x00000010    text vertical shift break
  705. # 0x00000008    text colour break
  706. # 0x00000004    text size break
  707. # 0x00000002    text font break
  708. # 0x00000001    text new paragraph
  709. # return param 2 (if defined) is text to add to output string
  710. # CHECK that input string is actually shorter - fatal error if it is not.
  711.  
  712. sub A ($$) {    # PRM wrong
  713.     my $self = shift;
  714.     ${$_[0]} =~ s#^\\A(.)[\n/]?##s;    # \n eaten here
  715.     $self->{'__PENDINGALIGN'} = $1;    # align code is case sensitive
  716.     0x01040000    # Force a *conditional* line break (PRM wrong)
  717. }
  718.  
  719. sub BC {
  720.     ${$_[1]} =~ s#^\\[BC]\s*(\d+)\s+(\d+)\s+(\d+)[/\n]##s;
  721.     pack 'I', ($1 << 8) | ($2 << 16) | ($3 << 24)
  722. }
  723. sub B ($$) {    # PRM wrong
  724.     my $self = $_[0];
  725.     $self->{'__BACK'} = BC (@_);
  726.     8    # Force a text break
  727. }
  728. sub C ($$) {    # PRM wrong
  729.     my $self = $_[0];
  730.     $self->{'__FORE'} = BC (@_);
  731.     8    # Force a text break
  732. }
  733.  
  734. # Don't think that we actually pay attention to this
  735. sub D ($$) {    # PRM wrong
  736.     my $self = shift;
  737.     ${$_[0]} =~ s#^\\D\s*(\d+)[/\n]##s;
  738.     ($self->{'__COLNUM'}) = $1;
  739.     undef
  740. }
  741.  
  742. sub F ($$) {    # PRM wrong
  743.     my $self = shift;
  744.     my $fonthash = $self->{'__FONT'};
  745.     # And the PRM says:
  746.     # ${$_[0]} =~ s#^\\F(\d\d?)(\S+)\s+(\d+)(\s+(\d+))?[/\n]##s;
  747.     # And the truth is:
  748.     ${$_[0]} =~ s#^\\F\s*(\d\d?)\s*(\S+)\s+([\d.]+)(\s+([\d.]+))?[/\n]##s;
  749.     # ($num, $name, $width, $size)
  750.     $fonthash->{$1} = [$2, $5, $3];    # 5 because 4 is the outer nesting ()
  751.     2    # Don't carry on
  752.     # Pathalogical programmers write
  753.     # \0Hello\F0 Trinity.Bold 12/ W\F0 Homerton.Medium 12/orld
  754. }
  755.  
  756. sub digit ($$) {    # PRM wrong
  757.     my $self = shift;
  758.     ${$_[0]} =~ s#^\\(\d\d?)[\n/]?##s;    # \n eaten here
  759.     # One point where I don't want undef == 0
  760.     return 0 if defined ($self->{'__CURFONT'}) and $self->{'__CURFONT'} == $1;
  761.     # Force a canonical numeric form, so that "03" and "3" hash identically
  762.     $self->{'__CURFONT'} = 0 + $1;
  763.     0x006    # Text break. Underline does *not* change if font size changes
  764. }
  765.  
  766. sub L ($$) {    # PRM wrong
  767.     my $self = shift;
  768.     ${$_[0]} =~ s#^\\L\s*(\d+)[/\n]##s;
  769.     $self->{'__LEAD'} = point2draw (0 + $1);    # Mustn't pass in raw $1
  770.     0    # Carry on.
  771. }
  772.  
  773. sub M ($$) {    # PRM wrong
  774.     my $self = shift;
  775.     ${$_[0]} =~ s#^\\M\s*(\d+)\s+(\d+)[/\n]##s;
  776.     $self->{'__PENDINGM'} = [$1, $2];
  777.     0x01000000    # Carry on. Mad! Well, it would be except that Draw interprets
  778.         # M commands as being relevant to the next line, not this one.
  779. }
  780.  
  781. sub P ($$) {    # PRM wrong
  782.     my $self = shift;
  783.     ${$_[0]} =~ s#^\\P\s*(\d+)[/\n]##s;
  784.     $self->{'__PLEAD'} = point2draw (0 + $1);
  785.     0x01000000    # Carry on.
  786. }
  787.  
  788. sub U ($$) {    # PRM wrong
  789.     my $self = shift;
  790.     if (${$_[0]} =~ s#^\\U\.[/]?##) {    # This one is strict
  791.     undef $self->{'__UPOS'};
  792.     undef $self->{'__UWIDTH'};
  793.     } else {
  794.     my $size = point2draw ($self->CurrentFont()->PointY()) / 256;
  795.     ${$_[0]} =~ s#^\\U\s*((-?[\d]+)\s+(\d+))[/\n]##s;    # Definately \d
  796.     # ($pos, $width)
  797.     $self->{'__UPOS'} = $2 * $size;
  798.     $self->{'__UWIDTH'} = $3 * $size;
  799.     }
  800.     0x100    # Underline break.
  801. }
  802.  
  803.  
  804. sub V ($$) {    # PRM wrong
  805.     my $self = shift;
  806.     ${$_[0]} =~ s#^\\V\s*(-?\d+)/?##s;    # definately \d - decimals not allowed
  807.     # for text - is up, but for paper co-ordinates y positive is upwards
  808.     $self->{'__UPOS'} += $self->{'__VERT'} = point2draw (-$1);    # - ensures copy
  809.     # underline does not shift!
  810.     0x010    # Text break, not underline break
  811. }
  812.  
  813. sub hyphen ($$) {    # minus/hyphen    soft hyphen    PRM wrong
  814.     ${$_[1]} =~ s#^\\-/?##s;
  815.     # See XFont_Paint - this is comment. But perl can scan for it at split time.
  816.     (0, "\25-\n")    # Carry on.
  817. }
  818.  
  819. sub newline ($$) {    # newline
  820.     ${$_[1]} =~ s#^\\\n##s;
  821.     0x10000    # Force line break
  822. }
  823.  
  824. sub backslash ($$) {    # backslash
  825.     ${$_[1]} =~ s#^\\\\##s;
  826.     (0, '\\')    # Carry on.
  827. }
  828.  
  829. sub semicolon ($$) {    # semicolon    comment
  830.     ${$_[1]} =~ s#^\\;.*\n##;
  831.     0    # Carry on.
  832. }
  833.  
  834. %parser = (
  835.    'A'    => \&A,
  836.    'B'    => \&B,
  837.    'C'    => \&C,
  838.    'D'    => \&D,
  839.    'F'    => \&F,
  840.    'L'    => \&L,
  841.    'M'    => \&M,
  842.    'P'    => \&P,
  843.    'U'    => \&U,
  844.    'V'    => \&V,
  845.  
  846.    '-'    => \&hyphen,
  847.    "\n"    => \&newline,
  848.    '\\'    => \&backslash,
  849.    ';'    => \&semicolon,
  850. );
  851.  
  852. $parser{0} = $parser{1} = $parser{2} = $parser{3} = $parser{4} =
  853. $parser{5} = $parser{6} = $parser{7} = $parser{8} = $parser{9} = \&digit;
  854.  
  855. if ($mode eq 'L') {
  856.     $lax = 1;
  857.     $parser{'G'}    = \&G,
  858.     $parser{'T'}    = \&T;
  859.     $parser{'I'}    = \&I;
  860. }
  861.  
  862. # I
  863. # \IP/        text to here is index to page.
  864. # \II 4/    hidden page target
  865.  
  866. sub I ($$) {
  867.     my $self = shift;
  868.     ${$_[0]} =~ s#^\\IP[/\n]|^\\II\s*(\S+?)[/\n]##s;
  869.     0    # Carry on.
  870. }
  871.  
  872.  
  873. # T
  874. # \T./        clear tabs?
  875. # \TL 172/    set tabstop?
  876. # \TR 351/    ditto
  877. # \TC 1/
  878.  
  879.  
  880. sub T ($$) {
  881.     my $self = shift;
  882.     undef $self->{'__TAB_S'};
  883.     if (${$_[0]} =~ s#^\\T\s*\.[/\n]##) {
  884.     undef $self->{'__TAB'};
  885.     } else {
  886.     ${$_[0]} =~ s#^\\T([LRC])\s*(\d+)[/\n]##s;
  887.     $self->{'__TAB'}->{point2draw (0 + $2)}  = $1 . $2;
  888.     }
  889.     0
  890. }
  891.  
  892. sub G ($$) {
  893.     my $self = shift;
  894.     ${$_[0]} =~ s#^\\G\s+(\d+)\s+(\d+)\s+(\d+)\s+(\S+)[/\n]##s;
  895.     $3 ne '0' ? (0, " «Insert illustration $4 at $1, $2» ")
  896.           : (0, " «Insert illustration $4 at $1, $2 ¿$3?» ")
  897. }
  898.  
  899. # G
  900. # \G 357 156 0 ID0500000001
  901. # x, y, dunno, ID    never seen dunno != 0
  902. 1;
  903. __END__
  904.  
  905. =head1 NAME
  906.  
  907. RISCOS::Drawfile::TextArea::Parser
  908.  
  909. =head1 SYNOPSIS
  910.  
  911. =head1 DESCRIPTION
  912.  
  913. =head1 BUGS
  914.  
  915. =head1 AUTHOR
  916.  
  917. Nicholas Clark <F<nick@unfortu.net>>
  918.