package Prty::Sdoc::Code;
use base qw/Prty::Sdoc::Node/;
use strict;
use warnings;
use utf8;
our $VERSION = 1.124;
use Prty::Path;
use Prty::Ipc;
use Prty::String;
use Prty::Html::Listing;
# -----------------------------------------------------------------------------
=encoding utf8
=head1 NAME
Prty::Sdoc::Code - Code-Abschnitt
=head1 BASE CLASS
L<Prty::Sdoc::Node>
=head1 DESCRIPTION
Ein Objekt der Klasse repräsentiert einen Code-Abschniit
im Sdoc-Parsingbaum.
=head1 ATTRIBUTES
=over 4
=item parent => $parent
Verweis auf übergeordneten Knoten.
=item text => $text
Text des Code-Abschnitts. Im Gegensatz zu einem Paragraphen
enthält der Text eines Code-Knoten auch Leerzeilen.
=back
=head1 METHODS
=head2 Konstruktor
=head3 new() - Konstruktor
=head4 Synopsis
$node = $class->new($doc,$parent);
=head4 Description
Lies Code-Abschnitt aus Textdokument $doc und liefere
eine Referenz auf dieses Objekt zurück.
=cut
# -----------------------------------------------------------------------------
sub new {
my ($class,$doc,$parent,$att) = @_;
# Ein Code-Abschnitt beginnt mit
# a) | am Zeilenanfang gefolgt von Whitespace oder
# b) nur mit Whitespace oder
# c) mit "<<Code" am Zeilenende
#
# Der Abschnitt reicht im Falle von a) und b) so weit, bis der
# betreffende Anfang nicht mehr vorhanden ist und im Falle
# c) bis zu "<<Code"
my $text = '';
my $filter;
if (@$att) {
# Aufruf über %Code:
if (my $i = $att->extractKeyVal('listing')) {
push @$att,ln=>$i,bg=>2;
}
my $stop = $att->extractKeyVal('stop');
if (!defined $stop) {
if ($att->index('exec') >= 0 || $att->index('file') >= 0) {
$stop = ''; # Default für exec und file
}
else {
$stop = '.'; # normaler Default
}
}
my $indentation = ' ' x $att->extractKeyVal('indentation');
my $reStop = $stop eq ''? qr/^$/: qr/^\Q$indentation$stop\E$/;
my $reIndentation = qr/^$|^\Q$indentation/;
while (@{$doc->lines}) {
my $str = $doc->shiftLine->text;
# Der Code-Abschnitt endet mit der ersten Zeile, die
# den Stop-Pattern matcht
if ($str =~ /$reStop/) {
last;
}
$str =~ s/$reIndentation//; # Whitespace am Anfang entfernen
$text .= "$str\n";
}
}
else {
my $line = $doc->lines->[0]->text;
if ($line =~ /^\s*<<Code/) {
$line =~ /^(\s*)/;
my $reWS = qr/^$|^\Q$1/;
if ($line =~ s/\s*\|(.*)//) {
$filter = $1;
$filter =~ s/^\s+//;
$filter =~ s/\s+$//;
}
$line =~ s/<</>>/;
my $reStop = qr/^\Q$line/;
$doc->shiftLine;
while (@{$doc->lines}) {
my $str = $doc->shiftLine->text;
# Der Code-Abschnitt endet mit der ersten Zeile,
# die bei gleicher Einrückung auf <<Code endet.
if ($str =~ /$reStop/) {
last;
}
$str =~ s/$reWS//; # Whitespace am Anfang entfernen
$text .= "$str\n";
}
}
else {
$line =~ /^(\|?\s+)/;
my $re = substr($1,0,1) eq '|'? qr/^\|$|^\Q$1/: qr/^$|^\Q$1/;
while (@{$doc->lines}) {
my $line = $doc->lines->[0];
my $str = $line->text;
# Ein Code-Abschnitt endet mit der ersten Zeile,
# die nicht mit dem Anfang der Anfangszeile beginnt
# Ausnahme: Leerzeile bei Einrückung.
$str =~ s/$re// || last; # Zeilenanfang entfernen
$text .= "$str\n";
$doc->shiftLine;
}
}
}
$text =~ s/\s+$//;
# Objekt instantiieren (Child-Objekte gibt es nicht)
my $self = $class->SUPER::new(
parent=>undef,
type=>'Code',
text=>$text,
file=>undef,
exec=>undef,
filter=>undef,
ln=>undef,
cn=>0,
bg=>0,
esc=>1,
cotedo=>0,
extract=>undef,
language=>undef,
# class=>'sdoc-code',
class=>undef,
highlight=>undef,
);
$self->parent($parent);
# $self->lockKeys;
$self->set(@$att);
return $self;
}
# -----------------------------------------------------------------------------
=head2 Methods
=head3 dump() - Erzeuge externe Repräsentation für Code-Abschnitt
=head4 Synopsis
$str = $node->dump($format);
=head4 Description
Erzeuge eine externe Repräsentation des Code-Abschnitts
und liefere diese zurück.
=cut
# -----------------------------------------------------------------------------
sub dump {
my $self = shift;
my $format = shift;
# @_: @args
my $root = $self->rootNode;
my $cssPrefix = $root->get('cssPrefix');
my $minLnWidth = $root->get('minLnWidth');
my $text = $self->{'text'};
my $esc = $self->{'esc'};
my $extract = $self->{'extract'};
my $highlight = $self->{'highlight'};
if (my $file = $self->{'file'}) {
$text = Prty::Path->read($file);
}
elsif (my $execCmd = $self->{'exec'}) {
if ($execCmd =~ s/%FORMAT%/$format/g) {
$esc = 0;
}
($text) = Prty::Ipc->filter($execCmd,undef);
}
# Extraktion vor dem Filtern!
if ($extract) {
if ($text =~ /$extract/sm) {
$text = $1;
}
}
Prty::String->removeIndentation(\$text);
if (my $filterCmd = $self->{'filter'}) {
if ($filterCmd =~ s/%FORMAT%/$format/g) {
$esc = 0;
}
($text) = Prty::Ipc->filter($filterCmd,$text);
}
if ($self->{'bg'} == 2) { # Krücke
$esc = 0;
}
if ($esc && $format ne 'pod') {
$text = $self->expand($format,$text,0,@_);
}
my $h;
if ($format =~ /^e?html$/) {
$h = shift;
}
if ($h && $self->{'bg'} == 2) {
return Prty::Html::Listing->html($h,
colNumbers=>$self->{'cn'},
cssPrefix=>"$cssPrefix-code",
escape=>$self->{'cotedo'}, # oder doch 0? 1 wird für CoTeDo-SOURCE benötigt
lineNumbers=>$self->{'ln'} || 0,
minLineNumberWidth=>$root->{'minLnWidth'},
language=>$self->{'language'},
source=>\$text,
);
}
if (my $i = $self->{'ln'} || 0) {
my $n = $text =~ tr/\n//;
my $l = length $n;
if (my $minLnWidth = $root->{'minLnWidth'}) {
$l = $minLnWidth if $l < $minLnWidth;
}
$l = 1 if $l < 2;
if ($h) {
$text =~ s/^/
$h->tag('span',
class=>"$cssPrefix-code-ln",
sprintf('%*d',$l,$i++)
).' '/gme,
}
else {
$text =~ s/^/sprintf '%*d: ',$l,$i++/gme;
}
}
if ($format eq 'debug') {
return "CODE\n$text\n";
}
elsif ($h) {
my $ln = $self->{'ln'};
my $class = "$cssPrefix-".($self->{'class'} || 'code-pre');
if ($highlight) {
if (!defined $ln) {
$ln = 1; # bei highlight Zeilennummer als Default
}
$class .= sprintf ' brush: %s; toolbar: false',lc $highlight;
if ($minLnWidth) {
$class .= sprintf '; pad-line-numbers: %s',$minLnWidth;
}
if (!$ln) {
$class .= '; gutter: false';
}
}
return $h->tag('div',
class=>$highlight && $ln? "$cssPrefix-highlight-div":
"$cssPrefix-code-div",
$h->tag('pre',
class=>$class,
$text,
)
);
}
elsif ($format eq 'pod')
{
$text =~ s/^/ /mg;
return "$text\n\n";
}
elsif ($format eq 'man')
{
my $parent = $self->parent;
if ($parent && $parent->{'type'} eq 'Section' &&
$parent->{'childs'}->[0] == $self) {
# Sonderbehandlung für SYNOPSIS o.ä.
# Keine Einrückung wenn der Code-Knoten der erste
# (und vermutlich einzige) Knoten des Abschnitts ist
}
else {
$text =~ s/^/ /mg;
}
return "$text\n\n";
}
$self->throw(
q~SDOC-00001: Unbekanntes Format~,
Format=>$format,
);
}
# -----------------------------------------------------------------------------
=head1 VERSION
1.124
=head1 AUTHOR
Frank Seitz, L<http://fseitz.de/>
=head1 COPYRIGHT
Copyright (C) 2018 Frank Seitz
=head1 LICENSE
This code is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
# -----------------------------------------------------------------------------
1;
# eof