Coverage Summary

$statistics{$_[1][0][0][STREAM_DIR_TYPE]}++ unless not defined $_[1][0][0][STREAM_DIR_TYPE] or exists $embeddedParagraphs{$_[1][0][0][STREAM_DIR_TYPE]};

1728

100

246

1729

# perform special headline operations

1730

if ($_[1][0][0][STREAM_DIR_TYPE]==DIRECTIVE_HEADLINE)

1731

{

100

139

1732

# update headline stream by adding the token index of the headline

1733

push(@{$resultStreamRef->[STREAM_HEADLINES]}, @{$resultStreamRef->[STREAM_TOKENS]}-@{$_[1][0]});

1734

10415

1735

# add a copy of the variables valid at the end of the page

1736

$_[1][0][0][STREAM_DIR_HINTS]{vars}=dclone(\%variables);

1737

207

1738

# let the user know that something is going on

1739

print STDERR "\r", ' ' x length('[Info] '), '... ', $statistics{&DIRECTIVE_HEADLINE}, " chapters read."

1740

if $flags{vis}

1741

and not $statistics{&DIRECTIVE_HEADLINE} % $flags{vis};

1742

}

1743

elsif ($_[1][0][0][STREAM_DIR_TYPE]!=DIRECTIVE_COMMENT)

1744

{

1745

# the document starts with streamed content before the first headline,

1746

# this is considered an error except when this happens due to an import

1747

_semerr($_[0], "$sourceFile, line $_[1][1]: the first chapter needs a headline, please add one.") unless exists $flags{complainedAbout1stHeadline};

1748

1749

# update complaint flag

1750

if (exists $flags{complainedAbout1stHeadline} and $flags{complainedAbout1stHeadline} eq 'IMPORT')

1751

{delete $flags{complainedAbout1stHeadline};}

1752

else

1753

{$flags{complainedAbout1stHeadline}=1;}

1754

}

1755

194

1756

# this is for the parser to flag success

1757

1758

}

1759

}

1760

| document paragraph

1761

470

100

470

3845

{

348

1798

1762

# skip empty "paragraphs"

1763

unless ($_[2][0]=~/^\s*$/ or not @{$_[2][0]})

1764

326

460

{

326

1402

326

1494

1765

# add data to the output stream, if necessary

1766

push(@{$resultStreamRef->[STREAM_TOKENS]}, @{$_[2][0]});

1767

326

607

326

1557

1768

# update tag finish memory

1769

_updateTagFinishMem(scalar(@{$resultStreamRef->[STREAM_TOKENS]}));

1770

326

100

7264

100

1771

# update checksums, if necessary

1772

_updateChecksums($_[2][0], 'Paragraph_cache_hit') unless $_[2][0][0][STREAM_DIR_TYPE]==DIRECTIVE_BLOCK

1773

or $_[2][0][0][STREAM_DIR_TYPE]==DIRECTIVE_DLIST

1774

or $_[2][0][0][STREAM_DIR_TYPE]==DIRECTIVE_OLIST

1775

or $_[2][0][0][STREAM_DIR_TYPE]==DIRECTIVE_ULIST

1776

or $_[2][0][0][STREAM_DIR_TYPE]==DIRECTIVE_HEADLINE;

1777

326

1329

1778

# update ordered list flag as necessary

1779

$flags{olist}=0 unless $_[2][0][0][STREAM_DIR_TYPE]==DIRECTIVE_OLIST;

1780

326

1821

1781

# update statistics, if necessary

1782

$statistics{$_[2][0][0][STREAM_DIR_TYPE]}++ unless exists $embeddedParagraphs{$_[2][0][0][STREAM_DIR_TYPE]};

1783

326

100

2056

100

1784

260

1955

# perform special headline operations

1785

if ($_[2][0][0][STREAM_DIR_TYPE]==DIRECTIVE_HEADLINE)

1786

{

138

258

1557

1787

# update headline stream by adding the token index of the headline

1788

push(@{$resultStreamRef->[STREAM_HEADLINES]}, @{$resultStreamRef->[STREAM_TOKENS]}-@{$_[2][0]});

1789

10258

1790

# add a copy of the variables valid at the end of the page

1791

$_[2][0][0][STREAM_DIR_HINTS]{vars}=dclone(\%variables);

1792

303

1793

# let the user know that something is going on, if necessary

1794

print STDERR "\r", ' ' x length('[Info] '), '... ', $statistics{&DIRECTIVE_HEADLINE}, " chapters read."

1795

if $flags{vis}

1796

and not $statistics{&DIRECTIVE_HEADLINE} % $flags{vis};

1797

}

1798

elsif (

1799

$_[2][0][0][STREAM_DIR_TYPE]!=DIRECTIVE_COMMENT

1800

and not @{$resultStreamRef->[STREAM_HEADLINES]}

1801

and (

1802

not exists $flags{complainedAbout1stHeadline}

1803

or $flags{complainedAbout1stHeadline} eq 'IMPORT'

1804

)

1805

)

1806

{

1807

# the document starts with streamed content before the first headline,

1808

# this is considered an error except when this happens due to an import

1809

_semerr($_[0], "$sourceFile, line $_[2][1]: the first chapter needs a headline, please add one.") unless exists $flags{complainedAbout1stHeadline};

1810

1811

# update complaint flag

1812

if (exists $flags{complainedAbout1stHeadline} and $flags{complainedAbout1stHeadline} eq 'IMPORT')

1813

{delete $flags{complainedAbout1stHeadline};}

1814

else

1815

{$flags{complainedAbout1stHeadline}=1;}

1816

}

1817

326

1499

1818

# this is for the parser to flag success

1819

1820

}

1821

}

1822

;

1823

1824

1825

# paragraph filters

1826

optional_paragraph_filter : # this makes it optional

1827

| '||'

1828

{

1829

# switch to pfiltered mode

1830

_stateManager(STATE_PFILTER);

1831

}

1832

paragraph_filters '||'

1833

{

1834

# back to default mode

1835

_stateManager(STATE_PFILTERED);

1836

1837

# supply filter list

1838

$_[3];

1839

}

1840

;

1841

1842

1843

# paragraph filter

1844

paragraph_filters : Word

1845

{

1846

# start a new filter list

1847

[[$_[1][0]], $_[1][1]];

1848

}

1849

| paragraph_filters '|' Word

1850

{

1851

# append to filter list and reply updated list

1852

push(@{$_[1][0]}, $_[3][0]);

1853

[$_[1][0], $_[3][1]];

1854

}

1855

;

1856

1857

1858

1859

# paragraph (default actions work)

1860

paragraph : built_paragraph

1861

| restored_paragraph

1862

;

1863

1864

1865

# build paragraph (default actions work)

1866

built_paragraph : optional_paragraph_filter

1867

475

100

475

2429

{

1868

# filter set?

1869

if ($_[1])

1870

{

1871

# prepare an extra "token" to start the next paragraph

1872

$flags{virtualParagraphStart}=1;

1873

1874

# Disable storage of a checksum. (A filter can make the paragraph depending

1875

# on something outside the paragraph - the paragraph becomes dynamic.)

1876

$flags{checksummed}=0;

1877

}

1878

}

1879

original_paragraph

1880

{

1881

471

1198

# reset the "extra token" flag (it already worked when the parser

1882

# reaches this point)

1883

$flags{virtualParagraphStart}=0;

1884

471

100

2284

1885

# filters installed and active?

1886

if ($_[1])

1887

{

1888

# Does the caller want to evaluate code?

1889

if ($safeObject)

1890

{

1891

# update active contents base data, if necessary

1892

430

if ($flags{activeBaseData})

70102

1893

{

1894

no strict 'refs';

1895

${join('::', ref($safeObject) ? $safeObject->root : 'main', 'PerlPoint')}=dclone($flags{activeBaseData});

1896

}

1897

1898

# peform filter call(s)

1899

my $result=_pfilterCall($_[0], $_[1][0], $_[3][0], $_[3][1]);

1900

1901

# reply unmodified paragraph in case of an error

1902

return $_[3] unless defined $result;

1903

1904

# make the result part of the input stream, if any

1905

_stackInput($_[0], @$result) if $result;

1906

1907

# reset the "end of input reached" flag if necessary

1908

$readCompletely=0 if $readCompletely;

1909

1910

# supply nothing here, the result must be reparsed first

1911

['', $_[3][2]];

1912

}

1913

else

1914

{

1915

# filters cannot be run, inform user

1916

warn "[Warn] $sourceFile, line $_[1][1]: Active Content is disabled, paragraph cannot be filtered.\n" unless $flags{display} & DISPLAY_NOWARN;

1917

1918

# supply the unmodified paragraph

1919

$_[3];

1920

}

1921

}

1922

else

1923

463

1743

{

1924

# no filter: provide paragraph data

1925

$_[3];

1926

}

1927

}

1928

| non_filterable_paragraph

1929

;

1930

1931

# original paragraph (not composed, unmodified)

1932

original_paragraph: headline

1933

| optionally_dotted_text

1934

239

100

239

574

{

240

100

3192

1935

# remove leading dummy tokens which might have been produced by "standalone macros"

1936

splice(@{$_[1][0]}, 1, 1) while @{$_[1][0]}>1 and !ref($_[1][0][1]) and $_[1][0][1] eq DUMMY_TOKEN;

1937

1938

# check if this paragraph consists of exactly one table only

1939

239

100

391

# or exactly one tag which is allowed to exists standalone,

100

1940

# or exactly one embedded region

1941

if (

1942

239

3459

(

1943

# starting with a table tag or standalone tag?

1944

@{$_[1][0]}>1

1945

and ref($_[1][0][1]) eq 'ARRAY'

1946

and $_[1][0][1][STREAM_DIR_TYPE]==DIRECTIVE_TAG

1947

and (

1948

$_[1][0][1][STREAM_DIR_DATA]=~/^(TABLE)$/

1949

or (

1950

$_[1][0][1][STREAM_DIR_DATA]=~/^(\w+)$/

1951

and (

1952

(

1953

exists $tagsRef->{$1}

1954

and exists $tagsRef->{$1}{standalone}

1955

and $tagsRef->{$1}{standalone}

1956

)

1957

or $1 eq 'EMBED'

1958

)

1959

)

1960

)

1961

1962

# ending with the same tag?

1963

and ref($_[1][0][-2]) eq 'ARRAY'

1964

and $_[1][0][-2][STREAM_DIR_TYPE]==DIRECTIVE_TAG

1965

and $_[1][0][-2][STREAM_DIR_DATA] eq $1

1966

1967

# both building the same tag?

1968

and $_[1][0][-2][STREAM_DIR_DATA+1] eq $_[1][0][1][STREAM_DIR_DATA+1]

1969

)

1970

)

1971

{

1972

# remove the enclosing paragraph stuff - just return the contents (table / tag)

201

1973

shift(@{$_[1][0]}); # text paragraph opener

1974

pop(@{$_[1][0]}); # text paragraph trailer

1975

}

1976

239

863

1977

# pass (original or modified) data

1978

$_[1];

1979

}

1980

| verbatim

1981

| comment

1982

| dstream_entrypoint

1983

| table_paragraph

1984

| compound_block

1985

| list

1986

# variable assigments should not be filtered, but moving them

1987

# to "non_filterable_paragraphs" causes additional shift/reduce

1988

# conflicts ... hm, this should be solved

1989

| variable_assignment

1990

;

1991

1992

# non filterable paragraph (filtering control paragraphs which produce

1993

# nothing directly makes no sense)

1994

non_filterable_paragraph : Empty_line

1995

| condition

1996

| alias_definition

1997

;

1998

1999

# paragraph restored from cache (default action works)

2000

restored_paragraph : Paragraph_cache_hit

2001

;

2002

2003

# headline

2004

headline : headline_level

2005

407

{

2006

# switch to headline mode

2007

_stateManager(STATE_HEADLINE);

2008

258

2009

# update headline level hints

2010

$flags{headlineLevel}=$_[1][0];

2011

521

2012

# trace, if necessary

2013

warn "[Trace] $sourceFile, line $_[1][1]: Headline (of level $_[1][0]) starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2014

}

2015

basics optional_headline_shortcut Empty_line

2016

319

{

2017

# back to default mode

2018

_stateManager(STATE_DEFAULT);

2019

340

2020

# trace, if necessary

2021

warn "[Trace] $sourceFile, line $_[5][1]: Headline completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2022

160

166

2119

3587

2023

# remove trailing whitespaces (the final one represents the final newline)

2024

pop(@{$_[3][0]}) while @{$_[3][0]} and $_[3][0][-1]=~/^\s*$/;

2025

100

376

2026

# abbreviation declared?

2027

if ($_[4][0])

2028

{

2029

# remove trailing whitespaces which separated a shortcut directive from

2030

# the long headline title version, if a shortcut was specified

2031

$_[3][0][-1]=~s/\s+$//;

2032

# remove leading and trailing whitespaces from the shortcut

2033

$_[4][0]=~s/^\s+//;

2034

$_[4][0]=~s/\s+$//;

2035

}

2036

208

2037

# update related data

2038

@olistLevels=();

2039

512

2040

336

# update directive counter and the level hierarchy memory

2041

$#headlineIds=$flags{headlineLevel}-1;

2042

$headlineIds[$flags{headlineLevel}-1]=++$flags{headlinenr};

2043

856

2044

# prepare result (data part and shortcut string)

2045

my %hints=(

2046

nr => ++$directiveCounter,

2047

shortcut => $_[4][0],

2048

458

docstreams => {},

2049

);

2050

my $data=[

2051

# opener directive (including headline level)

2052

526

[\%hints, DIRECTIVE_HEADLINE, DIRECTIVE_START, $_[1][0]],

2053

# the list of enclosed literals

2054

@{$_[3][0]},

2055

# final directive (including headline level again)

2056

[\%hints, DIRECTIVE_HEADLINE, DIRECTIVE_COMPLETE, $_[1][0]]

2057

];

2058

621

2059

# update checksums (done here because hits need special handling)

2060

_updateChecksums($data, 'Headline_cache_hit');

2061

221

2062

# update pointer to the current docstream hash

2063

$flags{chapterDocstreams}=$hints{docstreams};

2064

595

2065

# reply data

2066

[$data, $_[5][1]];

2067

}

2068

| Headline_cache_hit

2069

{

2070

# update headline level hint

2071

$flags{headlineLevel}=$_[1][0][0][STREAM_DIR_DATA];

2072

2073

# reset chapter docstream hash and update the appropriate pointer

2074

$flags{chapterDocstreams}=$_[1][0][0][STREAM_DIR_HINTS]{docstreams}={};

2075

2076

# supply what you got unchanged

2077

$_[1];

2078

}

2079

;

2080

2081

# headline level

2082

headline_level : '='

2083

1283

{

2084

# switch to headline intro mode

2085

_stateManager(STATE_HEADLINE_LEVEL);

2086

809

2087

# start new counter and reply it

2088

[$flags{headlineLevelOffset}+1, $_[1][1]];

2089

}

2090

| headline_level '='

2091

558

{

2092

# update counter and reply it

2093

[$_[1][0]+1, $_[1][1]];

2094

}

2095

;

2096

2097

# optional headline shortcut

2098

optional_headline_shortcut : # this makes it optional

2099

633

{

2100

# nothing declared: supply an empty shortcut string

2101

['', $lineNrs{$inHandle}];

2102

}

2103

| '~' words_or_spaces

2104

{

2105

# reply the shortcut string

2106

[join('', @{$_[2][0]}), $lineNrs{$inHandle}];

2107

}

2108

;

2109

2110

# condition paragraph

2111

condition : '?'

2112

{

2113

# switch to condition mode

2114

_stateManager(STATE_CONDITION);

2115

2116

# trace, if necessary

2117

warn "[Trace] $sourceFile, line $_[1][1]: Condition paragraph starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2118

}

2119

basics Empty_line

2120

{

2121

# back to default mode

2122

_stateManager(STATE_DEFAULT);

2123

2124

# trace, if necessary

2125

warn "[Trace] $sourceFile, line $_[4][1]: condition completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2126

2127

# The condition is written in Perl, anything passed really?

159

2128

# And does the caller want to evaluate the code?

2129

if (@{$_[3][0]} and $safeObject)

2130

{

2131

# trace, if necessary

2132

warn "[Trace] Evaluating condition ...\n" if $flags{trace} & TRACE_SEMANTIC;

2133

2134

# update active contents base data, if necessary

2135

277

if ($flags{activeBaseData})

121

198017

2136

341

{

2137

no strict 'refs';

2138

${join('::', ref($safeObject) ? $safeObject->root : 'main', 'PerlPoint')}=dclone($flags{activeBaseData});

2139

}

2140

146

2141

# make the Perl code a string and evaluate it

2142

my $perl=join('', @{$_[3][0]});

2143

326

$^W=0;

2144

11659

warn "[Trace] $sourceFile, line $_[3][1]: Evaluating condition code:\n\n$perl\n\n\n" if $flags{trace} & TRACE_ACTIVE;

2145

my $result=ref($safeObject) ? $safeObject->reval($perl) : eval(join(' ', '{package main; no strict;', $perl, '}'));

2146

$^W=1;

2147

2148

# check result

2149

if ($@)

2150

{_semerr($_[0], "$sourceFile, line $_[3][1]: condition code could not be evaluated: $@.");}

2151

else

2152

{

2153

# trace, if necessary

2154

warn "[Trace] Condition is ", (defined $result and $result) ? 'true, parsing continues' : 'false, parsing is temporarily suspended', ".\n" if $flags{trace} & TRACE_ACTIVE or $flags{trace} & TRACE_SEMANTIC;

2155

2156

# success - configure parser behaviour according to result

2157

$flags{skipInput}=1 unless (defined $result and $result);

2158

}

2159

}

2160

else

2161

{

2162

# trace, if necessary

2163

warn "[Trace] Condition is not evaluated because of disabled active contents.\n" if $flags{trace} & TRACE_SEMANTIC;

2164

}

2165

2166

# we have to supply something, but it should be nothing (note that this is a *paragraph*, so reply a *string*)

2167

['', $_[4][1]];

2168

}

2169

;

2170

2171

# a list consists of a number of certain elements (default actions work)

2172

list : list_part

2173

| list list_part

2174

{

2175

# update token list and reply it

2176

push(@{$_[1][0]}, @{$_[2][0]});

2177

[$_[1][0], $_[2][1]];

2178

}

2179

| list list_shift list_part

2180

{

2181

# update statistics, if necessary (shifters are not passed as standalone paragraphs, so ...)

2182

$statistics{$_[2][0][0][1]}++;

2183

2184

# add shift informations to related list parts: the predecessor

2185

# gets informations about a following shift, the successor about

2186

# a predecessing shift

2187

@{$_[1][0][-1]}[STREAM_DIR_DATA+3, STREAM_DIR_DATA+4]

2188

=@{$_[3][0][ 0]}[STREAM_DIR_DATA+1, STREAM_DIR_DATA+2]

2189

=@{$_[2][0][ 0]}[STREAM_DIR_TYPE, STREAM_DIR_DATA];

2190

2191

# update token list and reply it

2192

push(@{$_[1][0]}, @{$_[2][0]}, @{$_[3][0]});

2193

[$_[1][0], $_[3][1]];

2194

}

2195

;

2196

2197

# list parts (partial lists)

2198

list_part : olist

2199

100

{

2200

# the first point may start by a certain number, check this

2201

my $start=(defined $_[1][0][0][STREAM_DIR_DATA] and $_[1][0][0][STREAM_DIR_DATA]>1) ? $_[1][0][0][STREAM_DIR_DATA] : 1;

2202

2203

# embed the points into list directives

2204

my %hints=(nr=>++$directiveCounter);

2205

[

2206

[

2207

# opener directive

2208

[\%hints, DIRECTIVE_OLIST, DIRECTIVE_START, $start, (0) x 4],

2209

# the list of enclosed literals

2210

@{$_[1][0]},

2211

# final directive

2212

[\%hints, DIRECTIVE_OLIST, DIRECTIVE_COMPLETE, $start, (0) x 4]

2213

2214

$_[1][1]

2215

];

2216

}

2217

| ulist

2218

{

2219

# reset ordered list flag

2220

$flags{olist}=0;

2221

2222

# embed the points into list directives

2223

my %hints=(nr=>++$directiveCounter);

2224

[

2225

108

[

2226

# opener directive

2227

102

[\%hints, DIRECTIVE_ULIST, DIRECTIVE_START, 0, (0) x 4],

2228

# the list of enclosed literals

2229

@{$_[1][0]},

2230

# final directive

2231

[\%hints, DIRECTIVE_ULIST, DIRECTIVE_COMPLETE, 0, (0) x 4]

2232

2233

$_[1][1]

2234

];

2235

}

2236

| dlist

2237

{

2238

# reset ordered list flag

2239

$flags{olist}=0;

2240

2241

# embed the points into list directives

2242

my %hints=(nr=>++$directiveCounter);

2243

[

2244

[

2245

# opener directive

2246

[\%hints, DIRECTIVE_DLIST, DIRECTIVE_START, 0, (0) x 4],

2247

# the list of enclosed literals

2248

@{$_[1][0]},

2249

# final directive

2250

[\%hints, DIRECTIVE_DLIST, DIRECTIVE_COMPLETE, 0, (0) x 4]

2251

2252

$_[1][1]

2253

];

2254

}

2255

;

2256

2257

# ordered list

2258

olist : opoint

2259

| olist opoint

2260

{

2261

# update token list and reply it

2262

push(@{$_[1][0]}, @{$_[2][0]});

2263

[$_[1][0], $_[2][1]];

2264

}

2265

;

2266

2267

# unordered list

2268

ulist : upoint

2269

| ulist upoint

2270

{

2271

# update token list and reply it

2272

push(@{$_[1][0]}, @{$_[2][0]});

2273

[$_[1][0], $_[2][1]];

2274

}

2275

;

2276

2277

# definition list

2278

dlist : dpoint

2279

| dlist dpoint

2280

{

2281

# update token list and reply it

2282

push(@{$_[1][0]}, @{$_[2][0]});

2283

[$_[1][0], $_[2][1]];

2284

}

2285

;

2286

2287

# ordered list point

2288

opoint : opoint_opener

2289

{

2290

# switch to opoint mode

2291

_stateManager(STATE_OPOINT);

2292

2293

# trace, if necessary

2294

warn "[Trace] $sourceFile, line $_[1][1]: Ordered list point starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2295

}

2296

text

2297

{

2298

# update statistics (list points are not passed as standalone paragraphs, so ...)

2299

$statistics{&DIRECTIVE_OPOINT}++;

2300

2301

# trace, if necessary

2302

warn "[Trace] $sourceFile, line $_[3][1]: Ordered list point completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2303

100

150

2304

# remove leading whitespaces from point text (it separated number wildcard and literal text part)

2305

splice(@{$_[3][0]}, 1, 1) while not ref($_[3][0][1]) and $_[3][0][1]=~/^\s*$/;

2306

2307

# reply data (they are already well prepared except that they are marked as text)

2308

$_[3][0][0][STREAM_DIR_TYPE]=$_[3][0][-1][STREAM_DIR_TYPE]=&DIRECTIVE_OPOINT;

2309

100

309

2310

# update list level hints as necessary

2311

$olistLevels[0]=(($flags{olist} or $_[1][0]) and @olistLevels) ? $olistLevels[0]+1 : 1;

2312

2313

# add a level hint, if necessary

2314

if ($_[1][0] and not $flags{olist} and $olistLevels[0]>1)

2315

{

2316

push(@{$_[3][0][0]}, $olistLevels[0]);

2317

push(@{$_[3][0][-1]}, $olistLevels[0]);

2318

}

2319

2320

# update ordered list flag

2321

$flags{olist}=1;

2322

2323

# update checksums, if possible

2324

$flags{checksummed}=0 unless $flags{virtualParagraphStart};

2325

_updateChecksums($_[3][0], 'Opoint_cache_hit');

2326

2327

# supply result

2328

$_[3];

2329

}

2330

| Opoint_cache_hit

2331

{

2332

# update list level hints as necessary

2333

$olistLevels[0]=($flags{olist} and @olistLevels) ? $olistLevels[0]+1 : 1;

2334

2335

# update continued list points

2336

$_[1][0][0][STREAM_DIR_DATA]=$olistLevels[0] if @{$_[1][0][0]}>3;

2337

2338

# update ordered list flag

2339

$flags{olist}=1;

2340

2341

# supply updated stream snippet

2342

$_[1];

2343

}

2344

;

2345

2346

# ordered list point opener sequence - determining if a former list should be continued

2347

# (simply reply a flag)

2348

opoint_opener : '#'

2349

{[0, $_[1][1]];}

2350

| '#' '#'

2351

{[1, $_[1][1]];}

2352

;

2353

2354

# unordered list point

2355

upoint : '*'

2356

{

2357

# switch to upoint mode

2358

_stateManager(STATE_UPOINT);

2359

2360

# trace, if necessary

2361

warn "[Trace] $sourceFile, line $_[1][1]: Unordered list point starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2362

}

2363

text

2364

{

2365

# update statistics (list points are not passed as standalone paragraphs, so ...)

2366

$statistics{&DIRECTIVE_UPOINT}++;

2367

2368

# trace, if necessary

2369

warn "[Trace] $sourceFile, line $_[3][1]: Unordered list point completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2370

100

370

2371

# remove leading whitespaces from point text (it separated bullet and literal text part)

2372

splice(@{$_[3][0]}, 1, 1) while not ref($_[3][0][1]) and $_[3][0][1]=~/^\s*$/;

2373

289

2374

# remove trailing whitespaces from point text (it represents the final newline character)

2375

splice(@{$_[3][0]}, -2, 1) while not ref($_[3][0][-2]) and $_[3][0][-2]=~/^\s*$/;

2376

2377

# reply data (they are already well prepared except that they are marked as text)

2378

$_[3][0][0][STREAM_DIR_TYPE]=$_[3][0][-1][STREAM_DIR_TYPE]=&DIRECTIVE_UPOINT;

2379

2380

130

# update checksums, if possible

2381

$flags{checksummed}=0 unless $flags{virtualParagraphStart};

2382

_updateChecksums($_[3][0], 'Upoint_cache_hit');

2383

2384

# supply result

2385

$_[3];

2386

}

2387

| Upoint_cache_hit

2388

;

2389

2390

2391

# definition list point

2392

dpoint : dlist_opener

2393

{

2394

}

2395

text

2396

{

2397

# update statistics (list points are not passed as standalone paragraphs, so ...)

2398

$statistics{&DIRECTIVE_DPOINT}++;

2399

2400

# trace, if necessary

2401

warn "[Trace] $sourceFile, line $_[3][1]: Definition list point completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2402

2403

# remove leading whitespaces from point text (it separated point introduction and literal text part)

2404

splice(@{$_[3][0]}, 1, 1) while not ref($_[3][0][1]) and $_[3][0][1]=~/^\s*$/;

2405

2406

# reply data (they are already well prepared except that they are marked as text, and that the definition item stream needs to be added)

2407

my ($hints1, $hints2, $hints3)=({nr=>++$directiveCounter}, {nr=>++$directiveCounter}, {nr=>++$directiveCounter});

2408

$_[3][0][0]=[$hints1, DIRECTIVE_DPOINT, DIRECTIVE_START];

2409

$_[3][0][-1]=[$hints1, DIRECTIVE_DPOINT, DIRECTIVE_COMPLETE];

2410

2411

# insert the definition item stream and an envelope for the explanation part

2412

splice(@{$_[3][0]}, 1, 0,

2413

[$hints2, DIRECTIVE_DPOINT_ITEM, DIRECTIVE_START],

2414

@{$_[1][0]},

2415

[$hints2, DIRECTIVE_DPOINT_ITEM, DIRECTIVE_COMPLETE],

2416

[$hints3, DIRECTIVE_DPOINT_TEXT, DIRECTIVE_START],

2417

);

2418

splice(@{$_[3][0]}, -1, 0, [$hints3, DIRECTIVE_DPOINT_TEXT, DIRECTIVE_COMPLETE]);

2419

2420

# update checksums, if possible

2421

$flags{checksummed}=0 unless $flags{virtualParagraphStart};

2422

_updateChecksums($_[3][0], 'Dpoint_cache_hit');

2423

2424

# supply the result

2425

$_[3];

2426

}

2427

| Dpoint_cache_hit

2428

;

2429

2430

2431

# definition list opener

2432

dlist_opener : Colon

2433

{

2434

# switch to dlist item mode

2435

_stateManager(STATE_DPOINT_ITEM);

2436

2437

# trace, if necessary

2438

warn "[Trace] $sourceFile, line $_[1][1]: Definition list point starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2439

}

2440

elements Colon

2441

{

2442

# switch to dlist body mode

2443

_stateManager(STATE_DPOINT);

2444

2445

# simply pass the elements

2446

[$_[3][0], $_[4][1]];

2447

}

2448

;

2449

2450

2451

# compound block

2452

compound_block : block

2453

| compound_block block

2454

{

2455

# this is tricky - to combine both blocks, we have to remove the already

2456

# embedded stop/start directives and to supply the ...

2457

[

2458

[

141

2459

# ... original collection WITHOUT the final directive ...

2460

@{$_[1][0]}[0..$#{$_[1][0]}-1],

2461

# insert two additional newline characters (restoring the original empty line)

2462

"\n\n",

2463

# ... combined with the new block, except of its INTRO directive

2464

@{$_[2][0]}[1..$#{$_[2][0]}],

2465

2466

$_[2][1]

2467

];

2468

}

2469

| compound_block block_flagnew compound_block

2470

{

2471

# update statistics (for the first part which is completed by the intermediate flag paragraph)

2472

$statistics{&DIRECTIVE_BLOCK}++;

2473

2474

# this is simply a list of both blocks

2475

[

2476

[

2477

# original collection

2478

@{$_[1][0]},

2479

# ... followed by the new block

2480

@{$_[3][0]},

2481

2482

$_[3][1]

2483

];

2484

}

2485

;

2486

2487

# control paragraph: block connector

2488

block_flagnew : '-'

2489

{

2490

# switch to control mode

2491

_stateManager(STATE_CONTROL);

2492

2493

# trace, if necessary

2494

warn "[Trace] $sourceFile, line $_[1][1]: New block flag starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2495

}

2496

Empty_line

2497

{

2498

# back to default mode

2499

_stateManager(STATE_DEFAULT);

2500

2501

# trace, if necessary

2502

warn "[Trace] $sourceFile, line $_[1][1]: New block flag completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2503

2504

# reply data (these are dummies because block connectors are not made part of the output stream)

2505

$_[3];

2506

}

2507

;

2508

2509

# block

2510

block : Ils

2511

105

{

2512

# switch to block mode

2513

_stateManager(STATE_BLOCK);

2514

775

2515

# trace, if necessary

2516

warn "[Trace] $sourceFile, line $_[1][1]: Block starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2517

}

2518

text

2519

108

{

2520

# trace, if necessary

2521

warn "[Trace] $sourceFile, line $_[3][1]: Block completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2522

2523

# reply data (they are almost perfect except that they are marked as text,

2524

121

# and that the initial spaces have to be inserted, and that a trailing newline

2525

277

# has to be removed)

103

2526

$_[3][0][0][STREAM_DIR_TYPE]=$_[3][0][-1][STREAM_DIR_TYPE]=DIRECTIVE_BLOCK;

2527

100

splice(@{$_[3][0]}, 1, 0, $_[1][0]);

366

2528

# remove the final newline made from the last carriage return, if any

2529

splice(@{$_[3][0]}, -2, 1) if @{$_[3][0]}>2 and defined $_[3][0][-2] and $_[3][0][-2] eq "\n";

2530

100

130

2531

134

# update checksums, if possible

2532

$flags{checksummed}=0 unless $flags{virtualParagraphStart};

2533

_updateChecksums($_[3][0], 'Block_cache_hit');

2534

2535

# supply result

2536

$_[3];

2537

}

2538

| Block_cache_hit

2539

;

2540

2541

# common text layer

2542

optionally_dotted_text : text

2543

| dotted_text

2544

;

2545

2546

# text

2547

text : literal

2548

363

100

363

7677

{

100

2549

# enter text mode - unless we are in a block (or point (which already set this mode itself))

2550

unless ( $parserState==STATE_BLOCK

2551

or $parserState==STATE_UPOINT

2552

or $parserState==STATE_OPOINT

2553

or $parserState==STATE_DPOINT

2554

or $parserState==STATE_DPOINT_ITEM

2555

or $parserState==STATE_DEFINITION

2556

or $parserState==STATE_TEXT

2557

)

2558

231

1101

{

2559

# switch to new mode

2560

_stateManager(STATE_TEXT);

2561

231

1702

2562

# trace, if necessary

2563

warn "[Trace] $sourceFile, line $_[1][1]: Text starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2564

}

2565

}

2566

optional_literals

2567

Empty_line

2568

363

1651

{

2569

# trace, if necessary

2570

warn "[Trace] $sourceFile, line $_[4][1]: Text completed.\n" unless not $flags{trace} & TRACE_PARAGRAPHS

2571

or $parserState==STATE_BLOCK

2572

or $parserState==STATE_UPOINT

2573

or $parserState==STATE_OPOINT

2574

or $parserState==STATE_DPOINT

2575

or $parserState==STATE_DPOINT_ITEM;

2576

363

1143

2577

# back to default mode

2578

_stateManager(STATE_DEFAULT);

2579

363

2912

2580

# remove the final EOL literal, if any

2581

pop(@{$_[3][0]}) if defined $_[3][0][-1] and $_[3][0][-1] eq 'EOL';

2582

363

100

2347

313

645

2583

# remove the final whitespace string made from the last carriage return, if any

2584

pop(@{$_[3][0]}) if defined $_[3][0][-1] and $_[3][0][-1] eq ' ';

2585

363

100

561

363

100

3317

164

2586

# reply data, if any

2587

340

1288

if ((@{$_[1][0]} and $_[1][0][0]) or @{$_[3][0]})

2588

{

2589

my %hints=(nr=>++$directiveCounter);

2590

[

2591

340

991

[

2592

# opener directive

2593

340

1244

[\%hints, DIRECTIVE_TEXT, DIRECTIVE_START],

340

2756

2594

# the list of enclosed literals

2595

@{$_[1][0]}, @{$_[3][0]},

2596

# final directive

2597

[\%hints, DIRECTIVE_TEXT, DIRECTIVE_COMPLETE],

2598

2599

$_[4][1],

2600

];

2601

}

2602

else

2603

131

{

2604

# reply nothing real

2605

[[()], $_[4][1]];

2606

}

2607

}

2608

;

2609

2610

# optionally dotted text - a helper construct to allow texts to be started by a dot

2611

dotted_text : '.'

2612

{

2613

# switch to new mode (to stop special handling of dots)

2614

_stateManager(STATE_TEXT);

2615

}

2616

text

2617

{

2618

# supply the text

2619

$_[3];

2620

}

2621

;

2622

2623

# verbatim block

2624

verbatim : Heredoc_open

2625

{

2626

# switch to verbatim mode

2627

_stateManager(STATE_VERBATIM);

2628

2629

# trace, if necessary

2630

warn "[Trace] $sourceFile, line $_[1][1]: Verbatim block starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2631

2632

# check close hint: should be different from "1"

2633

_semerr($_[0], "A heredoc close hint should be different from \"1\".") if $_[1][0] eq '1';

2634

2635

# store close hint

2636

$specials{heredoc}=$_[1][0];

2637

}

2638

literals_and_empty_lines

2639

Heredoc_close

2640

{

2641

# trace, if necessary

2642

warn "[Trace] $sourceFile, line $_[4][1]: Verbatim block completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2643

2644

# back to default mode

2645

_stateManager(STATE_DEFAULT);

2646

2647

# delete the initial newline (which follows the opener but is no part of the block)

2648

shift(@{$_[3][0]});

2649

2650

# reply data

2651

my %hints=(nr=>++$directiveCounter);

2652

[

2653

[

2654

# opener directive

2655

[\%hints, DIRECTIVE_VERBATIM, DIRECTIVE_START],

2656

# the list of enclosed literals

2657

@{$_[3][0]},

2658

# final directive

2659

[\%hints, DIRECTIVE_VERBATIM, DIRECTIVE_COMPLETE]

2660

2661

$_[4][1]

2662

];

2663

}

2664

;

2665

2666

# variable assignment

2667

variable_assignment : Named_variable '='

2668

180

{

2669

# switch to text mode to allow *all* characters starting a variable value!

2670

_stateManager(STATE_TEXT);

2671

270

2672

# trace, if necessary

2673

warn "[Trace] $sourceFile, line $_[1][1]: Variable assignment starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2674

}

2675

text

2676

{

154

2677

144

# remove text directives and the final space (made from the final EOL)

127

2678

shift(@{$_[4][0]});

2679

pop(@{$_[4][0]});

2680

176

334

2681

# make the text contents a string and store it

2682

$variables{$_[1][0]}=join('', @{$_[4][0]});

2683

366

2684

# the variable might have been reset

2685

delete($variables{$_[1][0]}) if $variables{$_[1][0]}=~/^\s*$/;

2686

407

2687

# update variable checksum

2688

$varChecksum=sha1_base64(nfreeze(\%variables));

2689

100

4343

2690

# propagate the setting to the stream, if necessary

2691

if ($flags{var2stream})

155

2692

{

2693

push(@{$resultStreamRef->[STREAM_TOKENS]}, [{}, DIRECTIVE_VARSET, DIRECTIVE_START, {var=>$_[1][0], value=>$variables{$_[1][0]}}]);

2694

2695

# update tag finish memory by the way

2696

_updateTagFinishMem(scalar(@{$resultStreamRef->[STREAM_TOKENS]}));

2697

}

2698

100

189

2699

# make the new variable setting available to embedded Perl code, if necessary

2700

457

if ($safeObject)

335777

2701

140

{

434

2702

no strict 'refs';

2703

${join('::', ref($safeObject) ? $safeObject->root : 'main', $_[1][0])}=$variables{$_[1][0]};

2704

}

2705

946

2706

# trace, if necessary

2707

warn "[Trace] $sourceFile, line $_[4][1]: Variable assignment: \$$_[1][0]=$variables{$_[1][0]}.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2708

262

2709

# flag this paragraph as internal

2710

['', $_[4][1]];

2711

}

2712

;

2713

2714

# comment

2715

comment : '/' '/'

2716

{

2717

# switch to comment mode

2718

_stateManager(STATE_COMMENT);

2719

153

2720

# trace, if necessary

2721

warn "[Trace] $sourceFile, line $_[1][1]: Comment starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2722

}

2723

optional_basics Empty_line

2724

{

2725

# back to default mode

2726

_stateManager(STATE_DEFAULT);

2727

2728

# trace, if necessary

2729

warn "[Trace] $sourceFile, line $_[5][1]: Comment completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2730

2731

# reply data, if necessary

2732

my %hints=(nr=>++$directiveCounter);

2733

$flags{skipcomments} ? [[()], $_[5][1]]

2734

: [

2735

[

2736

# opener directive

2737

[\%hints, DIRECTIVE_COMMENT, DIRECTIVE_START],

2738

# the list of enclosed literals

2739

@{$_[4][0]},

2740

# final directive

2741

[\%hints, DIRECTIVE_COMMENT, DIRECTIVE_COMPLETE]

2742

2743

$_[5][1]

2744

];

2745

}

2746

;

2747

2748

# stream entry point

2749

dstream_entrypoint : '~'

2750

{

2751

# no mode switch necessary

2752

178

2753

# trace, if necessary

2754

warn "[Trace] $sourceFile, line $_[1][1]: Stream entry point starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2755

}

2756

words Empty_line

2757

{

2758

# no mode switch necessary

2759

100

2760

# trace, if necessary

2761

warn "[Trace] $sourceFile, line $_[5][1]: Stream entry point completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2762

2763

# deactivate caching

2764

$flags{checksummed}=0;

2765

2766

100

233

# reply data as wished

2767

my $streamTitle=join('', @{$_[3][0]});

2768

unless (

2769

$flags{docstreaming}==DSTREAM_IGNORE

2770

or (

2771

$flags{docstreams2skip}

2772

and exists $flags{docstreams2skip}{$streamTitle}

2773

)

2774

)

2775

{

2776

# store stream title (both globally and locally)

2777

$resultStreamRef->[STREAM_DOCSTREAMS]{$streamTitle}=$flags{chapterDocstreams}{$streamTitle}=undef;

2778

100

2779

# special handling requested?

2780

if ($flags{docstreaming}==DSTREAM_HEADLINES)

2781

{

2782

# make this docstream entry point a headline

2783

# one level below the last real headline level

2784

my %hints=(nr=>++$directiveCounter, shortcut=>'');

2785

[

2786

[

2787

# opener directive (including headline level)

2788

[\%hints, DIRECTIVE_HEADLINE, DIRECTIVE_START, $flags{headlineLevel}+1],

2789

# the stream title becomes the "headline"

2790

$streamTitle,

2791

# final directive (including headline level again)

2792

[\%hints, DIRECTIVE_HEADLINE, DIRECTIVE_COMPLETE, $flags{headlineLevel}+1]

2793

2794

$_[5][1]

2795

];

2796

}

2797

# default handling

2798

else

2799

{

2800

my %hints=(nr=>++$directiveCounter);

2801

[

2802

[

2803

# directives

2804

[\%hints, DIRECTIVE_DSTREAM_ENTRYPOINT, DIRECTIVE_START, $streamTitle],

2805

2806

$_[5][1]

2807

];

2808

}

2809

}

2810

else

2811

{

2812

# configure parser to ignore eveything till the next stream entry point or headline

2813

# ... unless this is the *main* stream

2814

$flags{skipInput}=2 unless $streamTitle eq 'main';

2815

103

2816

# we have to supply something, but it should be nothing (note that this is a *paragraph*, so reply a *string*)

2817

['', $_[5][1]];

2818

}

2819

}

2820

;

2821

2822

# control paragraph: list shifts

2823

list_shift : list_shifter

2824

{

2825

# temporarily activate number detection

2826

push(@specialStack, $specials{number});

2827

$specials{number}=1;

2828

}

2829

optional_number

2830

{

2831

# restore previous number detection mode

2832

$specials{number}=pop(@specialStack);

2833

2834

# switch to control mode

2835

_stateManager(STATE_CONTROL);

2836

2837

# trace, if necessary

2838

warn "[Trace] $sourceFile, line $_[3][1]: List shift ", $_[1][0]==LIST_SHIFT_RIGHT ? 'right' : 'left', " starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2839

}

2840

Empty_line

2841

{

2842

# back to default mode

2843

_stateManager(STATE_DEFAULT);

2844

2845

# trace, if necessary

2846

warn "[Trace] $sourceFile, line $_[5][1]: List shift ", $_[1][0]==LIST_SHIFT_RIGHT ? 'right' : 'left', " completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

2847

100

2848

100

# update related data

2849

if ($_[1][0]==LIST_SHIFT_RIGHT)

2850

100

{unshift(@olistLevels, 0) for (1..(defined $_[3][0] ? $_[3][0] : 1));}

2851

else

2852

{shift(@olistLevels) for (1..(defined $_[3][0] ? $_[3][0] : 1));}

2853

2854

# reset ordered list flag

2855

$flags{olist}=0;

2856

2857

# reply data

2858

[

2859

100

[

100

2860

# opener directive (no explicit closing)

2861

[{}, $_[1][0]==LIST_SHIFT_RIGHT ? DIRECTIVE_LIST_RSHIFT : DIRECTIVE_LIST_LSHIFT, DIRECTIVE_START, defined $_[3][0] ? $_[3][0] : 1],

2862

2863

$_[5][1]

2864

];

2865

}

2866

;

2867

2868

# list shift characters

2869

list_shifter : '>'

2870

{

2871

# reply a flag

2872

[LIST_SHIFT_RIGHT, $_[1][1]];

2873

}

2874

| '<'

2875

{

2876

# reply a flag

2877

[LIST_SHIFT_LEFT, $_[1][1]];

2878

}

2879

;

2880

2881

# optional literals

2882

optional_literals : # this makes it optional

2883

124

{

2884

# start a new, empty list and reply it

2885

[[], $lineNrs{$inHandle}];

2886

}

2887

| literals # default action works perfectly

2888

;

2889

2890

# literals

2891

literals : literal # default action works

2892

| literals literal

2893

1332

2040

{

1332

2737

1332

3015

2894

1332

5999

# update token list and reply it

2895

push(@{$_[1][0]}, @{$_[2][0]});

2896

[$_[1][0], $_[2][1]];

2897

}

2898

;

2899

2900

# optional literals and empty lines

2901

optional_literals_and_empty_lines : # this makes it optional

2902

{

2903

# start a new, empty list and reply it

2904

[[], $lineNrs{$inHandle}];

2905

}

2906

| literals_and_empty_lines # default action works perfectly

2907

;

2908

2909

# literals and empty lines

2910

literals_and_empty_lines : literal_or_empty_line # default action works

2911

| literals_and_empty_lines literal_or_empty_line

2912

1243

1721

{

1243

2188

1243

26534

2913

1243

5096

# update token list and reply it

2914

push(@{$_[1][0]}, @{$_[2][0]});

2915

[$_[1][0], $_[2][1]];

2916

}

2917

;

2918

2919

# literal or empty line

2920

literal_or_empty_line : literal # default action works

2921

| Empty_line

2922

518

{

2923

# start a new token list and reply it

2924

[[$_[1][0]], $_[1][1]];

2925

}

2926

;

2927

2928

# literals are basics or EOL

2929

literal : basic # default action works

2930

| EOL

2931

270

1642

{

2932

# start a new token list and reply it

2933

[[$_[1][0]], $_[1][1]];

2934

}

2935

;

2936

2937

# optional basics

2938

optional_basics : # this makes it optional

2939

{

2940

# start a new, empty list and reply it

2941

[[], $lineNrs{$inHandle}];

2942

}

2943

| basics # default action works perfectly

2944

;

2945

2946

# basics

2947

basics : basic # default action works perfectly

2948

| basics basic

2949

235

353

{

235

529

235

763

2950

235

1040

# update token list and reply it

2951

push(@{$_[1][0]}, @{$_[2][0]});

2952

[$_[1][0], $_[2][1]];

2953

}

2954

;

2955

2956

2957

# basic (base element or table stuff)

2958

basic : element

2959

| table

2960

| table_separator

2961

;

2962

2963

2964

# elements

2965

elements : element # default action works perfectly

2966

| elements element

2967

{

2968

# update token list and reply it

2969

push(@{$_[1][0]}, @{$_[2][0]});

2970

[$_[1][0], $_[2][1]];

2971

}

2972

;

2973

2974

2975

# base element (numbers are no base element because they are usually words - numbers are detected very temporarily)

2976

element : Word

2977

2034

9965

{

2978

# start a new token list and reply it

2979

[[$_[1][0]], $_[1][1]];

2980

}

2981

| Space

2982

955

6143

{

2983

# start a new token list and reply it

2984

[[$_[1][0]], $_[1][1]];

2985

}

2986

| Named_variable

2987

107

100

107

708

{

2988

# flag that this paragraph uses variables (a cache hit will only be useful if variable settings will be unchanged)

2989

$flags{checksummed}[4]=1 unless exists $flags{checksummed} and not $flags{checksummed};

2990

107

100

1009

2991

# start a new token list and reply it

2992

[[exists $variables{$_[1][0]} ? $variables{$_[1][0]} : join('', '$', $_[1][0])], $_[1][1]];

2993

}

2994

| Symbolic_variable

2995

100

290

{

2996

# flag that this paragraph uses variables (a cache hit will only be useful if variable settings will be unchanged)

2997

$flags{checksummed}[4]=1 unless exists $flags{checksummed} and not $flags{checksummed};

2998

271

2999

# start a new token list and reply it

3000

[[exists $variables{$_[1][0]} ? $variables{$_[1][0]} : join('', '$', "{$_[1][0]}")], $_[1][1]];

3001

}

3002

| StreamedPart

3003

{

3004

# start a new token list and reply it

3005

# (the passed stream is already a reference)

3006

[$_[1][0], $_[1][1]];

3007

}

3008

| tag

3009

| embedded

3010

| included

3011

;

3012

3013

3014

# optional number

3015

optional_number : # this makes it optional

3016

{[undef, $lineNrs{$inHandle}];}

3017

| Number

3018

;

3019

3020

3021

# words

3022

words : Word

3023

203

{

3024

# start a new token list and reply it

3025

[[$_[1][0]], $_[1][1]];

3026

}

3027

| words Word

3028

{

3029

# update token list and reply it

3030

push(@{$_[1][0]}, $_[2][0]);

3031

[$_[1][0], $_[2][1]];

3032

}

3033

;

3034

3035

# words or spaces

3036

words_or_spaces : word_or_space

3037

{

3038

# start a new token list and reply it

3039

[[$_[1][0]], $_[1][1]];

3040

}

3041

| words_or_spaces word_or_space

3042

{

3043

# update token list and reply it

3044

push(@{$_[1][0]}, $_[2][0]);

3045

[$_[1][0], $_[2][1]];

3046

}

3047

;

3048

3049

# word or space

3050

word_or_space : Word

3051

| Space

3052

;

3053

3054

3055

# tag

3056

tag : Tag_name

3057

112

672

{

3058

# trace, if necessary

3059

warn "[Trace] $sourceFile, line $_[1][1]: Tag $_[1][0] starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

3060

112

100

909

3061

# temporarily activate special "<" *as necessary*

3062

112

100

502

my $possible= (exists $macros{$_[1][0]} and $macros{$_[1][0]}->[2]) # macro: evaluate body flag;

3063

112

188

|| $tagsRef->{$_[1][0]}{__flags__}{__body__}; # tag with body;

3064

push(@specialStack, $specials{'<'}), $specials{'<'}=1 if $possible; # enable tag body, if necessary

3065

push(@specialStack, $possible); # flags what is on stack;

3066

114

3067

112

100

1020

# temporarily activate specials "{" and "}" *as necessary*

100

3068

push(@specialStack, @specials{('{', '}')}), @specials{('{', '}')}=(1) x 2

3069

if (exists $macros{$_[1][0]} and %{$macros{$_[1][0]}->[0]}) # macro: evaluate declared options;

3070

|| $tagsRef->{$_[1][0]}{__flags__}{__options__}; # tag with options;

3071

112

339

3072

# deactivate boost

3073

$flags{noboost}=1;

3074

}

3075

optional_tagpars

3076

112

234

{

3077

# reactivate boost

3078

$flags{noboost}=0;

3079

3080

112

100

963

# restore special states of "{" and "}", if necessary

100

3081

@specials{('{', '}')}=splice(@specialStack, -2, 2)

3082

if (exists $macros{$_[1][0]} and %{$macros{$_[1][0]}->[0]}) # macro: evaluate declared options;

3083

|| $tagsRef->{$_[1][0]}{__flags__}{__options__}; # tag with options;

3084

112

337

100

3085

112

1275

# check options in general if declared mandatory

3086

if (

3087

not @{$_[3][0]}

3088

and exists $tagsRef->{$_[1][0]}

3089

and exists $tagsRef->{$_[1][0]}{options}

3090

and $tagsRef->{$_[1][0]}{options}==&TAGS_MANDATORY

3091

)

3092

{

3093

# display error message

3094

warn "\n\n[Fatal] $sourceFile, line $_[3][1]: Missing mandatory options of tag $_[1][0]\n";

3095

3096

# this is an syntactical error, stop parsing

3097

$_[0]->YYAbort;

3098

}

3099

}

3100

optional_tagbody

3101

112

152

{

3102

# scopy

3103

my $ignore;

3104

112

307

3105

# trace, if necessary

3106

warn "[Trace] $sourceFile, line $_[5][1]: Tag $_[1][0] completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

3107

112

289

3108

112

100

129

# build parameter hash, if necessary

112

414

3109

my %pars;

3110

if (@{$_[3][0]})

3111

{

266

3112

# the list already consists of key/value pairs

3113

%pars=@{$_[3][0]}

3114

}

3115

112

295

3116

# Tag condition set?

3117

if (exists $pars{_cnd_})

3118

{

3119

# ok, if the condition was true or could not be evaluated, return just the body

3120

# (so that the tag or macro is ignored)

3121

unless (_evalTagCondition($pars{_cnd_}, $sourceFile, $_[5][1]))

3122

{return([[@{$_[5][0]} ? @{$_[5][0]} : ()], $_[5][1]]);}

3123

else

3124

{

3125

# strip off this special option before the tag or macro is furtherly processed

3126

delete $pars{_cnd_};

3127

}

3128

}

3129

112

100

318

3130

# tags require special handling

3131

unless (exists $macros{$_[1][0]})

3132

101

122

{

100

3133

101

7397

# check tag body in general if declared mandatory

3134

if (

3135

not @{$_[5][0]}

3136

and exists $tagsRef->{$_[1][0]}

3137

and exists $tagsRef->{$_[1][0]}{body}

3138

and $tagsRef->{$_[1][0]}{body}==&TAGS_MANDATORY

3139

)

3140

{

3141

# display error message

3142

warn "[Fatal] $sourceFile, line $_[5][1]: Missing mandatory body of tag $_[1][0]\n";

3143

3144

# this is an syntactical error, stop parsing

3145

$_[0]->YYAbort;

3146

}

3147

101

100

700

3148

# invoke hook function, if necessary

3149

if (exists $tagsRef->{$_[1][0]} and exists $tagsRef->{$_[1][0]}{hook})

3150

454

{

3151

# make an option hash

3152

my $options={@{$_[3][0]}};

3153

3154

# call hook function (use eval() to guard yourself)

327

105

3155

my $rc;

3156

eval {$rc=&{$tagsRef->{$_[1][0]}{hook}}($_[1][1], $options, dclone($_[5][0]), $anchors, join('-', @headlineIds), $flags{headlinenr})};

3157

3158

# check result

3159

unless ($@)

3160

{

3161

{

3162

# semantic error?

3163

++$_semerr, last if $rc==PARSING_ERROR;

3164

3165

# syntactical error?

3166

$_[0]->YYAbort, last if $rc==PARSING_FAILED;

3167

194

3168

# tag to ignore, or even everything covered?

3169

$ignore=$rc, last if $rc==PARSING_IGNORE or $rc==PARSING_ERASE;

3170

3171

# update options (might be modified, and checking for a difference

3172

# might take more time then just copying the replied values)

3173

@{$_[3][0]}=%$options;

3174

3175

# all right?

3176

if ($rc==PARSING_OK)

3177

100

{

3178

# is this a tag that will invoke a finish hook?

3179

if (exists $tagsRef->{$_[1][0]}{finish})

3180

{

3181

# update number of tags to finish in the currently built stream section, if necessary

3182

$pendingTags->[1]++;

3183

3184

# Disable storage of a checksum. (A finish hook makes the paragraph depending

3185

# on something potentially outside the paragraph - the paragraph becomes dynamic.)

3186

$flags{checksummed}=0;

3187

}

3188

3189

# well done

3190

last;

3191

}

3192

3193

# or even superb?

3194

$_[0]->YYAccept, last if $rc==PARSING_COMPLETED;

3195

3196

# something is wrong here

3197

warn "[Warn] Tags $_[1][0] tag hook replied unexpected result $rc, ignored.\n";

3198

}

3199

}

3200

else

3201

{warn "[Warn] Error in tags $_[1][0] tag hook: $@\n"}

3202

100

3203

# rebuild parameter hash, if necessary

3204

if (@{$_[3][0]})

3205

{

3206

# the list already consists of key/value pairs

3207

%pars=@{$_[3][0]}

3208

}

3209

}

3210

}

3211

112

100

485

3212

# this might be a macro as well as a tag - so what?

3213

unless (exists $macros{$_[1][0]})

3214

101

527

{

3215

# update statistics

3216

$statistics{&DIRECTIVE_TAG}++;

3217

101

575

3218

# reply tag data as necessary

3219

unless (defined $ignore)

3220

101

502

{

3221

# supply a complete tag

3222

my %hints=(nr=>++$directiveCounter);

3223

[

3224

101

362

[

101

317

3225

# opener directive

3226

196

[\%hints, DIRECTIVE_TAG, DIRECTIVE_START, $_[1][0], \%pars, scalar(@{$_[5][0]})],

101

759

3227

# the list of enclosed literals, if any

3228

101

100

259

@{$_[5][0]} ? @{$_[5][0]} : (),

3229

# final directive

3230

[\%hints, DIRECTIVE_TAG, DIRECTIVE_COMPLETE, $_[1][0], \%pars, scalar(@{$_[5][0]})]

3231

3232

$_[5][1]

3233

];

3234

}

3235

elsif ($ignore==PARSING_IGNORE)

3236

{

3237

# supply the body, ignore the tag "envelope" ("hide" the tag)

3238

[

3239

[

3240

# the list of enclosed literals, if any

3241

@{$_[5][0]} ? @{$_[5][0]} : (),

3242

3243

$_[5][1]

3244

];

3245

}

3246

elsif ($ignore==PARSING_ERASE)

3247

{

3248

# reply nothing real

3249

[[()], $_[5][1]];

3250

}

3251

else

3252

{die "[BUG] Unhandled flag $ignore.";}

3253

}

3254

else

3255

100

{

3256

# flag that this paragraph uses macros (a cache hit will only be useful if macro definitions will have been unchanged)

3257

$flags{checksummed}[3]=1 unless exists $flags{checksummed} and not $flags{checksummed};

3258

3259

# this is a macro - resolve it!

3260

my $macro=$macros{$_[1][0]}->[1];

3261

3262

# fill in parameters

3263

foreach my $par (keys %{$macros{$_[1][0]}->[0]})

100

3264

{

3265

my $value= exists $pars{$par} ? $pars{$par}

3266

: defined $macros{$_[1][0]}->[0]{$par} ? $macros{$_[1][0]}->[0]{$par}

3267

: '';

3268

$macro=~s/__${par}__/$value/g;

3269

}

3270

3271

# Bodyless macros need special care - the parser already got the subsequent token to

3272

# recognize that the macro was complete. Now, the macro replacement is reinserted into

3273

# the stream where it will be read by the next lexer operation which is enforced when

3274

# the parser needs a token again - and this will happen after processing the already

3275

# received token which stood behind the bodyless macro. Letting the parser process the

3276

# read token this way, this token would be streamed (in most cases) *before* the macro

3277

# replacement, while it was intented to come after it. So, if we detect this case, we

3278

# move this token *behind* the macro replacement. As for the parser, we replace

3279

# this token by something streamed to "nothing", currently a special string declared

3280

100

# as "Word" token.

3281

my $delayedToken;

3282

unless (@{$_[5][0]})

3283

{

3284

# insert the current token behind the imaginary body

3285

$delayedToken=new PerlPoint::Parser::DelayedToken($_[0]->YYCurtok, $_[0]->YYCurval);

3286

3287

# set new dummy values to let the parser work on

3288

# (something without effect and valid everywhere a tag is)

3289

$_[0]->YYCurtok('Word');

3290

$_[0]->YYCurval([DUMMY_TOKEN, $_[0]->YYCurval->[1]]);

3291

}

3292

100

326

3293

# finally, pass the constructed text back to the input stream (by stack)

3294

_stackInput($_[0], (map {$_ eq '__body__' ? dclone($_[5][0]) : split(/(\n)/, $_)} split(/(__body__)/, $macro)), $delayedToken ? $delayedToken : ());

3295

100

3296

# reset the "end of input reached" flag if necessary

3297

$readCompletely=0 if $readCompletely;

3298

3299

# reply nothing real

3300

[[()], $_[5][1]];

3301

378

}

3302

}

3303

;

3304

3305

# optional tag parameters

3306

optional_tagpars : # this makes it optional

3307

{[[], $lineNrs{$inHandle}];}

3308

| used_tagpars

3309

;

3310

3311

3312

used_tagpars : '{' tagpars '}'

3313

438

{

3314

# supply the parameters

3315

[$_[2][0], $_[3][1]];

3316

}

3317

;

3318

3319

# tag parameters

3320

tagpars : tagpar

3321

| tagpars Space tagpar

3322

{

442

187

3323

# update parameter list

3324

push(@{$_[1][0]}, @{$_[3][0]});

3325

219

3326

# supply updated parameter list

3327

[$_[1][0], $_[3][1]];

3328

}

3329

;

3330

3331

# tag parameter

3332

tagpar : Word

3333

151

329

{

3334

151

326

# backslashes should pass in tag options

3335

push(@specialStack, $lexerFlags{backsl});

3336

$lexerFlags{backsl}=LEXER_TOKEN;

3337

3338

151

1475

# temporarily make "=" and quotes the only specials,

3339

151

2059

# but take care to reset the remaining settings defined

3340

151

982

push(@specialStack, [(%specials)], $specials{'='});

3341

@specials{keys %specials}=(0) x scalar(keys %specials);

3342

@specials{('=', '"')}=(1, 1);

3343

}

3344

'='

3345

151

575

{

3346

# restore special "=" setting

3347

$specials{'='}=pop(@specialStack);

3348

}

3349

tagvalue

3350

151

224

{

151

2582

3351

# restore special settings

3352

%specials=@{pop(@specialStack)};

3353

151

803

3354

# restore backslash flag

3355

$lexerFlags{backsl}=pop(@specialStack);

3356

151

1571

3357

# supply flag and value

3358

[[$_[1][0], $_[5][0]], $_[5][1]];

3359

}

3360

;

3361

3362

tagvalue : Word

3363

| '"' basics '"'

3364

220

{

346

3365

# build a string and supply it

3366

[join('', @{$_[2][0]}), $_[3][1]];

3367

}

3368

;

3369

3370

# optional tag body

3371

optional_tagbody : # this makes it optional

3372

{

3373

170

# if we are here, "<" *possibly* was marked to be a special - now it becomes what is was before

3374

100

# (take care the stack is filled correctly!)

3375

my $possible=pop(@specialStack); # was the body enabled?

3376

$specials{'<'}=pop(@specialStack) if $possible; # if so, restore the stack

3377

116

3378

# supply an empty result

3379

[[], $lineNrs{$inHandle}];

3380

}

3381

| '<'

3382

{

3383

169

# if we are here, "<" was marked to be a special - now it becomes what is was before

3384

199

# (take care the stack is filled correctly!)

3385

my $possible=pop(@specialStack); # can be ignored - surely the body was enabled!

3386

$specials{'<'}=pop(@specialStack); # restore the stack

3387

240

3388

263

# temporarily activate special ">"

3389

push(@specialStack, @specials{('>')});

3390

@specials{('>')}=1;

3391

}

3392

literals '>'

3393

196

{

3394

# reset ">" setting

3395

@specials{('>')}=pop(@specialStack);

3396

384

3397

# reply the literals

3398

[$_[3][0], $_[4][1]];

3399

}

3400

;

3401

3402

3403

table : Table

3404

{

3405

# trace, if necessary

3406

warn "[Trace] $sourceFile, line $_[1][1]: Table starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

3407

3408

# check nesting

3409

_semerr($_[0], "$sourceFile, line $_[3][1]: Nested tables are not supported by this parser version.")

3410

if @tableSeparatorStack and not $flags{nestedTables};

3411

3412

# temporarily activate specials "{" and "}"

3413

push(@specialStack, @specials{('{', '}')});

3414

@specials{('{', '}')}=(1, 1);

3415

3416

153

# empty lines have to be ignored in tables

3417

push(@specialStack, $lexerFlags{el});

3418

$lexerFlags{el}=LEXER_IGNORE;

3419

3420

# deactivate boost

3421

$flags{noboost}=1;

3422

}

3423

used_tagpars

3424

{

3425

# reactivate boost

3426

$flags{noboost}=0;

3427

3428

# restore previous handling of empty lines

3429

$lexerFlags{el}=pop(@specialStack);

3430

3431

# restore special state of "{" and "}"

3432

@specials{('{', '}')}=splice(@specialStack, -2, 2);

3433

3434

# read parameters and adapt them, if necessary

3435

100

my %tagpars=@{$_[3][0]};

3436

3437

193

if (exists $tagpars{rowseparator})

3438

{

3439

$tagpars{rowseparator}=quotemeta($tagpars{rowseparator});

3440

$tagpars{rowseparator}="\n" if $tagpars{rowseparator} eq '\\\\n';

3441

}

3442

100

3443

# mark table start

3444

$tableColumns=0-(

3445

exists $tagpars{gracecr} ? $tagpars{gracecr}

3446

: (not exists $tagpars{rowseparator} or $tagpars{rowseparator} eq "\n") ? 1

3447

: 0

3448

);

3449

100

155

100

3450

# store specified column separator (or default)

3451

unshift(@tableSeparatorStack, [

3452

exists $tagpars{separator} ? quotemeta($tagpars{separator}) : '\|',

3453

exists $tagpars{rowseparator} ? $tagpars{rowseparator} : "\n",

3454

]);

3455

}

3456

optional_literals_and_empty_lines Tabled

3457

{

3458

# build parameter hash, if necessary

122

3459

my %pars;

3460

if (@{$_[3][0]})

3461

{

3462

# the list already consists of key/value pairs

3463

%pars=@{$_[3][0]}

3464

}

3465

3466

# Tag condition set?

3467

if (exists $pars{_cnd_})

3468

{

3469

# ok, if the condition was true or could not be evaluated,

3470

# stop processing of this tag (there is no body, so return an empty stream)

3471

unless (_evalTagCondition($pars{_cnd_}, $sourceFile, $_[6][1]))

3472

{return([[()], $_[6][1]]);}

3473

else

3474

{

3475

# strip off this special option before the tag or macro is furtherly processed

3476

delete $pars{_cnd_};

3477

}

3478

}

3479

100

3480

100

# add row separator information unless it was defined by the user itself

3481

$pars{rowseparator}='\n' unless exists $pars{rowseparator};

3482

$pars{rowseparator}='\\\\n' if $pars{rowseparator} eq '\\n';

3483

3484

# store nesting level information

3485

$pars{__nestingLevel__}=@tableSeparatorStack;

3486

3487

# If we are here and found anything in the table, it is

3488

# possible that a final row was closed and a new one opened

3489

# (e.g. at the end of the last table line, if rows are separated

3490

# by "\n"). Because the table is completed now, these tags can

3491

# be removed to get the common case of an opened but not yet

123

146

3492

# completed table cell.

3493

splice(@{$_[5][0]}, -4, 4) if @{$_[5][0]}

3494

and ref($_[5][0][-1]) eq 'ARRAY'

3495

and @{$_[5][0][-1]}==4

3496

and $_[5][0][-1][STREAM_DIR_TYPE] eq DIRECTIVE_TAG

3497

and $_[5][0][-1][STREAM_DIR_STATE] eq DIRECTIVE_START

3498

and $_[5][0][-1][STREAM_DIR_DATA] eq 'TABLE_COL';

3499

3500

# normalize table rows (no need of auto format)

3501

($pars{__titleColumns__}, $pars{__maxColumns__})=_normalizeTableRows($_[5][0], 0);

3502

3503

# warn user in case of potential row width conflicts

3504

warn qq([Warn] $sourceFile, line $_[1][1]: The maximum cell number per row ($pars{__maxColumns__}) was not detected in the first row (which has $pars{__titleColumns__} columns).\n) if $pars{__titleColumns__}<$pars{__maxColumns__} and not ($flags{display} & DISPLAY_NOWARN);

3505

3506

# reset column separator memory, mark table completed

3507

shift(@tableSeparatorStack);

3508

$tableColumns=0;

3509

3510

# reply data in a "tag envelope" (for backends)

3511

my ($hints1, $hints2, $hints3)=({nr=>++$directiveCounter}, {nr=>++$directiveCounter}, {nr=>++$directiveCounter});

3512

[

3513

[

3514

# opener directives

3515

[$hints1, DIRECTIVE_TAG, DIRECTIVE_START, 'TABLE', \%pars],

3516

[$hints2, DIRECTIVE_TAG, DIRECTIVE_START, 'TABLE_ROW'],

3517

[$hints3, DIRECTIVE_TAG, DIRECTIVE_START, 'TABLE_COL'],

362

3518

# the list of enclosed literals reduced by the final two, if any

3519

@{$_[5][0]} ? @{$_[5][0]} : (),

3520

# final directive

3521

[$hints3, DIRECTIVE_TAG, DIRECTIVE_COMPLETE, 'TABLE_COL'],

3522

[$hints2, DIRECTIVE_TAG, DIRECTIVE_COMPLETE, 'TABLE_ROW'],

3523

[$hints1, DIRECTIVE_TAG, DIRECTIVE_COMPLETE, 'TABLE', \%pars]

3524

3525

$_[6][1]

3526

];

3527

}

3528

;

3529

3530

# table separator: this is a simple transformation rule

3531

table_separator : Table_separator

3532

134

248

{

3533

# update counter of completed table columns

3534

$tableColumns++;

3535

134

424

3536

# supply a simple seperator tag

3537

my %hints=(nr=>++$directiveCounter);

3538

134

100

13223

[

3539

[

3540

[\%hints, DIRECTIVE_TAG, DIRECTIVE_COMPLETE, 'TABLE_COL'],

3541

$_[1][0] eq 'c' ? ()

3542

: (

3543

[{}, DIRECTIVE_TAG, DIRECTIVE_COMPLETE, 'TABLE_ROW'],

3544

[{}, DIRECTIVE_TAG, DIRECTIVE_START, 'TABLE_ROW'],

3545

3546

[\%hints, DIRECTIVE_TAG, DIRECTIVE_START, 'TABLE_COL'],

3547

3548

$_[1][1]

3549

];

3550

}

3551

;

3552

3553

3554

table_paragraph : '@'

3555

{

3556

# switch to condition mode

3557

_stateManager(STATE_TABLE);

3558

3559

# trace, if necessary

3560

warn "[Trace] $sourceFile, line $_[1][1]: Table paragraph starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

3561

}

3562

words EOL

3563

{

3564

# store specified column separator

3565

unshift(@tableSeparatorStack, [quotemeta(join('', @{$_[3][0]})), "\n"]);

3566

}

3567

optional_literals Empty_line

3568

{

3569

# back to default mode

3570

_stateManager(STATE_DEFAULT);

3571

3572

# trace, if necessary

3573

warn "[Trace] $sourceFile, line $_[7][1]: Table paragraph completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

3574

3575

# reset column separator memory, mark table completed

3576

shift(@tableSeparatorStack);

3577

$tableColumns=0;

3578

3579

# build parameter hash (contains level information, which is always 1,

3580

# and various retranslation hints)

3581

my %pars=(

3582

__nestingLevel__ => 1,

3583

__paragraph__ => 1,

3584

separator => join('', @{$_[3][0]}),

3585

);

3586

3587

# If we are here and found anything in the table, a final row was

3588

# closed and a new one opened at the end of the last table line.

3589

# Because the table is completed now, the final opener tags can

3590

# be removed. This is done *here* and by pop() for acceleration.

3591

if (@{$_[6][0]}>4)

3592

{

3593

# delete final opener directives made by the final carriage return

3594

splice(@{$_[6][0]}, -2, 2);

3595

561

3596

# normalize table rows and autoformat headline fields

3597

($pars{__titleColumns__}, $pars{__maxColumns__})=_normalizeTableRows($_[6][0], 1);

3598

3599

# warn user in case of potential row width conflicts

3600

3601

3602

# reply data in a "tag envelope" (for backends)

3603

my %hints=(nr=>++$directiveCounter);

3604

[

3605

[

3606

# opener directives (note that first row and column are already opened by the initial carriage return stream)

3607

[\%hints, DIRECTIVE_TAG, DIRECTIVE_START, 'TABLE', \%pars],

3608

[{}, DIRECTIVE_TAG, DIRECTIVE_START, 'TABLE_ROW'],

3609

[{}, DIRECTIVE_TAG, DIRECTIVE_START, 'TABLE_HL'],

3610

# the list of enclosed literals reduced by the final two, if any

3611

@{$_[6][0]} ? @{$_[6][0]} : (),

3612

# final directive

3613

[\%hints, DIRECTIVE_TAG, DIRECTIVE_COMPLETE, 'TABLE', \%pars]

3614

3615

$_[7][1]

3616

];

3617

}

3618

else

3619

{

3620

# empty table - reply nothing real

3621

[[()], $_[7][1]];

3622

}

3623

}

3624

;

3625

3626

3627

embedded : Embed

3628

{

3629

410

# switch to embedding mode saving the former state (including *all* special settings)

3630

144

push(@stateStack, $parserState);

3631

push(@specialStack, [%specials]);

3632

_stateManager(STATE_EMBEDDING);

3633

136

3634

# trace, if necessary

3635

warn "[Trace] $sourceFile, line $_[1][1]: Embedding starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

3636

3637

# Disable storage of a checksum. (Dynamic parts may change or have changed.

3638

# Static parts are static of course, but the filter settings may vary.)

3639

$flags{checksummed}=0;

3640

3641

# temporarily activate specials "{" and "}"

3642

push(@specialStack, @specials{('{', '}')});

3643

@specials{('{', '}')}=(1, 1);

3644

3645

# deactivate boost

3646

$flags{noboost}=1;

3647

}

3648

used_tagpars

3649

{

3650

# reactivate boost

3651

$flags{noboost}=0;

3652

128

3653

# restore special state of "{" and "}"

3654

@specials{('{', '}')}=splice(@specialStack, -2, 2);

3655

}

3656

optional_literals_and_empty_lines Embedded

3657

124

{

3658

# restore former parser state (including *all* special settings)

388

3659

_stateManager(pop(@stateStack));

3660

%specials=@{pop(@specialStack)};

3661

151

3662

# build parameter hash, if necessary

200

3663

my %pars;

3664

if (@{$_[3][0]})

3665

{

191

3666

# the list already consists of key/value pairs

3667

%pars=@{$_[3][0]}

3668

}

3669

117

3670

# set default language, if necessary

3671

$pars{lang}='pp' unless exists $pars{lang};

3672

150

3673

# Tag condition set?

3674

if (exists $pars{_cnd_})

3675

{

3676

# ok, if the condition was true or could not be evaluated,

3677

# stop processing of this tag (there is no body, so return an empty stream)

3678

unless (_evalTagCondition($pars{_cnd_}, $sourceFile, $_[6][1]))

3679

{return([[()], $_[6][1]]);}

3680

else

3681

{

3682

# strip off this special option before the tag or macro is furtherly processed

3683

delete $pars{_cnd_};

3684

}

3685

}

3686

453

3687

# did the user exclude files of the language the embedded source is written in?

3688

my $langExcluded=not (

3689

not $flags{filter} # no general language filter is defined, so all languages are allowed, or

3690

or lc($pars{lang}) eq 'pp' # this is a PerlPoint file, or

3691

or (

3692

exists $pars{lang} # there is a general language filter,

3693

and $pars{lang}=~/^$flags{filter}$/i # and it allows to include files of this language

3694

)

3695

);

3696

211

3697

# set import filter as necessary

3698

my $filterSet=_setImportFilter($_[0], \%pars);

3699

100

213

3700

# Input filter to call?

3701

if (

3702

not $langExcluded # files in the language of the embedded one are not excluded in general

3703

and exists $pars{ifilter} # and there is an import filter

3704

)

3705

{

3706

# Can we invoke the filter code?

3707

unless ($safeObject)

3708

{

3709

# What a pity - but probably the unfiltered source is not what the backend

3710

# expects, so we need to ignore the embedded code completely for now. As

3711

# usually, this is done without warning.

3712

return([[()], $_[6][1]]);

3713

}

3714

else

3715

{

3716

# OK, we can try to invoke the filter.

3717

3718

# inform user

3719

warn qq([Warn] $sourceFile, line $_[1][1]: Running input filter.\n) if $flags{trace} & TRACE_ACTIVE;

3720

3721

# update active contents base data, if necessary

3722

481

if ($flags{activeBaseData})

102

3222

3723

{

3724

no strict 'refs';

3725

${join('::', ref($safeObject) ? $safeObject->root : 'main', 'PerlPoint')}=dclone($flags{activeBaseData});

3726

}

3727

3728

# We provide the text in a special variable @main::_ifilterText,

3729

# and the target type in a special variable $main::_ifilterType,

3730

217

# as well as the filename in a special var. $main::_ifilterFile.

16397

3731

{

3732

no strict 'refs';

3733

@{join('::', ref($safeObject) ? $safeObject->root : 'main', '_ifilterText')}=@{$_[5][0]};

3734

${join('::', ref($safeObject) ? $safeObject->root : 'main', '_ifilterType')}=$pars{lang};

3735

${join('::', ref($safeObject) ? $safeObject->root : 'main', '_ifilterFile')}=$sourceFile;

3736

}

3737

3738

# run the filter and catch what it supplies

3739

$_[5][0]=[ref($safeObject) ? $safeObject->reval($pars{ifilter}) : eval(join(' ', '{package main; no strict;', $pars{ifilter}, '}'))];

3740

897

3741

# check result

3742

if ($@)

3743

{

3744

# inform user, if necessary

3745

_semerr($_[0], qq($sourceFile, line $_[1][1]: input filter failed: $@.));

3746

3747

# ignore this part

3748

return([[()], $_[6][1]]);

3749

}

3750

}

3751

}

3752

100

465

100

3753

# check if we have to stream this code

3754

if (not defined($filterSet) or $langExcluded)

3755

{

3756

# filter error occured, or the caller wants to skip the embedded code:

3757

# we have to supply something, but it should be nothing

3758

[[()], $_[6][1]];

3759

}

3760

elsif (lc($pars{lang}) eq 'pp')

3761

{

3762

# embedded PerlPoint - pass it back to the parser (by stack)

3763

_stackInput($_[0], split(/(\n)/, join('', @{$_[5][0]})));

3764

3765

# reset the "end of input reached" flag if necessary

3766

$readCompletely=0 if $readCompletely;

3767

3768

# we have to supply something, but it should be nothing

3769

[[()], $_[6][1]];

3770

}

3771

elsif (lc($pars{lang}) eq 'perl')

3772

{

3773

# This is embedded Perl code, anything passed really?

328

3774

# And does the caller want to evaluate the code?

3775

if (@{$_[5][0]} and $safeObject)

3776

{

3777

# update active contents base data, if necessary

3778

219

if ($flags{activeBaseData})

71523

3779

{

3780

no strict 'refs';

3781

${join('::', ref($safeObject) ? $safeObject->root : 'main', 'PerlPoint')}=dclone($flags{activeBaseData});

3782

}

3783

192

3784

# make the code a string and evaluate it

3785

my $perl=join('', @{$_[5][0]});

3786

warn "[Trace] $sourceFile, line $_[6][1]: Evaluating this code:\n\n$perl\n\n\n" if $flags{trace} & TRACE_ACTIVE;

3787

142

3788

# ignore empty code

3789

if ($perl=~/\S/)

3790

100

567

{

3791

# well, there is something, evaluate it

3792

my $result=ref($safeObject) ? $safeObject->reval($perl) : eval(join(' ', '{package main; no strict;', $perl, '}'));

3793

10999

3794

# check result

3795

if ($@)

3796

{_semerr($_[0], "$sourceFile, line $_[6][1]: embedded Perl code could not be evaluated: $@.");}

3797

else

3798

100

{

3799

# success - make the result part of the input stream, if any

3800

_stackInput($_[0], split(/(\n)/, $result)) if defined $result;

3801

}

3802

3803

# reset the "end of input reached" flag if necessary

3804

$readCompletely=0 if $readCompletely;

3805

}

3806

}

3807

3808

# we have to supply something, but it should be nothing

3809

[[()], $_[6][1]];

3810

}

3811

else

3812

{

3813

# reply data in a "tag envelope" (for backends)

3814

my %hints=(nr=>++$directiveCounter);

3815

[

3816

[

3817

# opener directive

3818

[\%hints, DIRECTIVE_TAG, DIRECTIVE_START, 'EMBED', \%pars],

3819

# the list of enclosed literals, if any

3820

@{$_[5][0]} ? @{$_[5][0]} : (),

3821

# final directive

3822

[\%hints, DIRECTIVE_TAG, DIRECTIVE_COMPLETE, 'EMBED', \%pars]

3823

3824

$_[6][1]

3825

];

3826

}

3827

}

3828

;

3829

3830

3831

included : Include

3832

100

{

3833

# trace, if necessary

3834

warn "[Trace] $sourceFile, line $_[1][1]: Inclusion starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

3835

3836

# Disable storage of a checksum. (Files may change or have changed. Later on,

3837

# we could try to keep a files modification date unless it is a nested PerlPoint

3838

# source or a dynamic Perl part. For now, it seems to be sufficient that each file

3839

# is cached itself.)

3840

$flags{checksummed}=0;

3841

145

3842

# temporarily activate specials "{" and "}"

3843

push(@specialStack, @specials{('{', '}')});

3844

@specials{('{', '}')}=(1, 1);

3845

3846

# deactivate boost

3847

$flags{noboost}=1;

3848

}

3849

used_tagpars

3850

{

3851

# scopies

3852

my ($errors, $originalPath);

3853

3854

# reactivate boost

3855

$flags{noboost}=0;

3856

3857

# restore special state of "{" and "}"

3858

@specials{('{', '}')}=splice(@specialStack, -2, 2);

3859

173

3860

110

# check parameters: type and filename should be set at least

3861

my %tagpars=@{$_[3][0]};

3862

$errors++, _semerr($_[0], "$sourceFile, line $_[3][1]: You forgot to specify the name of your included file.") unless exists $tagpars{file};

3863

3864

# set default type, if necessary

3865

$tagpars{type}='pp' unless exists $tagpars{type};

3866

3867

# Tag condition set?

3868

if (exists $tagpars{_cnd_})

3869

{

3870

# ok, if the condition was true or could not be evaluated,

3871

# stop processing of this tag (there is no body, so return an empty stream)

3872

unless (_evalTagCondition($tagpars{_cnd_}, $sourceFile, $_[3][1]))

3873

{return([[()], $_[3][1]]);}

3874

else

3875

{

3876

# strip off this special option before the tag or macro is furtherly processed

3877

delete $tagpars{_cnd_};

3878

}

3879

}

3880

100

617

3881

# search specified directories for the file if necessary

3882

unless (-e $tagpars{file})

3883

{

3884

# pathes are stored in an already prepared array @libraryPath

3885

foreach my $path (@libraryPath)

3886

{

3887

100

my $newname="$path/$tagpars{file}";

3888

warn "[Trace] $sourceFile, line $_[3][1]: Trying include file name $newname for $tagpars{file}.\n" if $flags{trace} & TRACE_SEMANTIC;

3889

$tagpars{file}=$newname, last if -e $newname;

3890

}

3891

}

3892

1899

3893

# expand filename to avoid trouble by various names for the same file

3894

$tagpars{file}=catfile(abs_path(dirname($originalPath=$tagpars{file})), basename($tagpars{file}))

3895

or $errors++, semmerr("$sourceFile, line $_[3][1]: File name $tagpars{file} cannot be resolved.\n");

3896

711

3897

# smart inclusion?

3898

my $smart=1 if $tagpars{type}=~/^pp$/

3899

and exists $tagpars{smart} and $tagpars{smart}

3900

and exists $openedSourcefiles{$tagpars{file}};

3901

294

3902

# avoid circular source inclusion

3903

$errors++, _semerr($_[0], "$sourceFile, line $_[3][1]: Source file $originalPath was already opened before (full path: $tagpars{file}).") if $tagpars{type}=~/^pp$/

3904

and not $smart

3905

and grep($_ eq $tagpars{file}, @nestedSourcefiles);

3906

3907

100

438

100

3908

100

# PerlPoint headline offsets have to be positive numbers or certain strings

3909

$errors++, _semerr($_[0], "$sourceFile, line $_[3][1]: Invalid headline level offset $tagpars{headlinebase}, positive number or keywords BASE_LEVEL/CURRENT_LEVEL expected.") if $tagpars{type}=~/^pp$/i and exists $tagpars{headlinebase} and $tagpars{headlinebase}!~/^\d+$/ and $tagpars{headlinebase}!~/^(base|current)_level$/i;

3910

$tagpars{headlinebase}=$flags{headlineLevel} if exists $tagpars{headlinebase} and $tagpars{headlinebase}=~/^current_level$/i;

3911

$tagpars{headlinebase}=$flags{headlineLevel}-1 if exists $tagpars{headlinebase} and $tagpars{headlinebase}=~/^base_level$/i;

3912

159

3913

# all right?

3914

unless (defined $smart or defined $errors)

3915

682

{

3916

# check the filename

3917

if (-r $tagpars{file})

3918

{

3919

# store the files name and directory for later reference

3920

# (we could refer do that later, but using intermediate buffers

3921

# allows to keep the original values when switching the file in

3922

# background which happens with input filters)

3923

my $orgname=$tagpars{file};

3924

294

3925

# did the user exclude files of the language the embedded source is written in?

3926

my $typeExcluded=not (

3927

not $flags{filter} # no general language filter is defined, so all languages are allowed, or

3928

or lc($tagpars{type}) eq 'pp' # this is a PerlPoint file, or

3929

or (

3930

exists $tagpars{type} # there is a general language filter,

3931

and $tagpars{type}=~/^$flags{filter}$/i # and it allows to include files of this language

3932

)

3933

);

3934

3935

# try to set a set default import filter, if necessary

3936

if (exists $tagpars{import} and $tagpars{import} and $tagpars{import}!~/\D/)

3937

{

3938

# import format not set explicitly, scan file name for extension

3939

$tagpars{file}=~/\.(\w+)$/;

3940

$tagpars{import}=$1;

3941

3942

# success?

3943

delete $tagpars{import}, _semerr($_[0], qq($sourceFile, line $_[3][1]: could not determine import filter via file extension.)) unless $1;

3944

}

3945

214

3946

# arrange import as necessary

3947

my $filterSet=_setImportFilter($_[0], \%tagpars);

3948

100

160

3949

# Import filter to call?

3950

if (not $typeExcluded and exists $tagpars{ifilter})

3951

{

3952

# Can we invoke the filter code?

3953

unless ($safeObject)

3954

{

3955

# What a pity - but probably the unfiltered source is not what the backend

3956

# expects, so we need to ignore the embedded code completely for now. As

3957

# usually, this is done without warning.

3958

return([[()], $_[3][1]]);

3959

}

3960

else

3961

{

3962

# OK, we can try to invoke the filter.

3963

209

3964

# inform user

3965

warn qq([Warn] $sourceFile, line $_[1][1]: Running input filter.\n) if $flags{trace} & TRACE_ACTIVE;

3966

3967

# update active contents base data, if necessary

3968

280

if ($flags{activeBaseData})

5271

3969

{

3970

no strict 'refs';

3971

${join('::', ref($safeObject) ? $safeObject->root : 'main', 'PerlPoint')}=dclone($flags{activeBaseData});

3972

}

3973

3974

# open original file

3975

open(my $orgHandle, $tagpars{file});

3976

binmode($orgHandle);

3977

3978

# We provide the text in a special variable @main::_ifilterText,

3979

# and the target type in a special variable $main::_ifilterType,

3980

205

# as well as the filename in a special var. $main::_ifilterFile.

285

36305

3981

{

3982

no strict 'refs';

3983

@{join('::', ref($safeObject) ? $safeObject->root : 'main', '_ifilterText')}=<$orgHandle>;

3984

${join('::', ref($safeObject) ? $safeObject->root : 'main', '_ifilterType')}=$tagpars{type};

3985

${join('::', ref($safeObject) ? $safeObject->root : 'main', '_ifilterFile')}=$tagpars{file};

3986

}

3987

3988

# close original file

3989

close($orgHandle);

3990

13656

3991

502

# run the filter in the files directory and catch what it supplies

3992

my $startDir=cwd();

3993

525

chdir(dirname($orgname));

3994

2417

3995

my @ifiltered=ref($safeObject) ? $safeObject->reval($tagpars{ifilter}) : eval(join(' ', '{package main; no strict;', $tagpars{ifilter}, '}'));

3996

chdir($startDir);

3997

3998

# check result

3999

if ($@)

4000

{

4001

# inform user, if necessary

4002

_semerr($_[0], qq($sourceFile, line $_[1][1]: input filter failed: $@.));

4003

4004

# ignore this part

4005

return([[()], $_[3][1]]);

4006

}

4007

4008

1762

# ok, now "replace" the original file by a temporary one

4009

my ($tmpHandle, $tmpFilename)=tempfile(UNLINK => ($flags{trace} & TRACE_TMPFILES ? 0 : 1));

4010

$tagpars{file}=$tmpFilename;

4011

4012

print $tmpHandle @ifiltered;

4013

close($tmpHandle);

4014

}

4015

}

4016

349

100

4017

# check for errors

4018

if (not defined $filterSet)

4019

{

4020

# we have to supply something - but it should be nothing

4021

[[()], $_[3][1]];

4022

}

4023

# check specified file type

4024

elsif ($tagpars{type}=~/^pp$/i)

4025

{

4026

# update nesting stack

4027

push(@nestedSourcefiles, $orgname);

4028

109

4029

# update source file nesting level hint

4030

_predeclareVariables({_SOURCE_LEVEL=>scalar(@nestedSourcefiles)});

4031

4032

100

# build a hash of variables to "localize"

4033

my ($localizedVars, $localizeAll)=({}, 0);

4034

if (exists $tagpars{localize})

4035

100

{

4036

# special setting?

4037

if ($tagpars{localize}=~/^\s*__ALL__\s*$/)

4038

{

4039

# store a copy of all existing variables

4040

$localizedVars=dclone(\%variables);

4041

$localizeAll=1;

4042

}

4043

else

4044

{

4045

# store values of all variables to localize (passed by a comma separated list)

4046

$localizedVars={map {$_=>$variables{$_}} split(/\s*,\s*/, $tagpars{localize})};

4047

}

4048

100

4049

# the source level variable needs to be corrected

4050

$localizedVars->{_SOURCE_LEVEL}-- if exists $localizedVars->{_SOURCE_LEVEL};

4051

}

4052

4053

# we include a PerlPoint document, switch input handle

4054

92395

# (we intermediately have to close the original handle because of perl5.6.0 bugs)

4055

unshift(

4056

@inHandles, [

4057

tell($inHandle),

4058

$_[0]->{USER}->{INPUT},

4059

basename($sourceFile),

4060

$lineNrs{$inHandle},

4061

@flags{qw(headlineLevelOffset headlineLevel)},

4062

cwd(),

4063

$localizedVars, $localizeAll,

4064

496

]

4065

847

);

4066

114

close($inHandle);

4067

161

open($inHandle, $tagpars{file});

4068

119

binmode($inHandle);

4069

$_[0]->{USER}->{INPUT}='';

4070

$sourceFile=$tagpars{file};

4071

$lineNrs{$inHandle}=0;

4072

2389

4073

# change directory with file

4074

chdir(dirname($orgname));

4075

104

4076

# open a new input stack

4077

unshift(@inputStack, []);

4078

100

208

4079

# headline level offset declared?

4080

$flags{headlineLevelOffset}=exists $tagpars{headlinebase} ? $tagpars{headlinebase} : 0;

4081

4082

145

# store the filename in the list of opened sources, to avoid circular reopening

4083

# (it would be more perfect to store the complete path, is there a module for this?)

4084

$openedSourcefiles{$tagpars{file}}=1;

4085

564

4086

# we have to supply something, but it should be nothing

4087

[[()], $_[3][1]];

4088

}

4089

elsif ($flags{filter} and $tagpars{type}!~/^(($flags{filter})|(?:parsed)?example)$/i)

4090

{

4091

# this file does not need to be included, nevertheless

4092

# we have to supply something - but it should be nothing

4093

[[()], $_[3][1]];

4094

}

4095

elsif ($tagpars{type}=~/^perl$/i)

4096

{

4097

# Does the caller want to evaluate code?

4098

if ($safeObject)

4099

{

4100

# update active contents base data, if necessary

4101

240

if ($flags{activeBaseData})

174

6052

4102

{

4103

no strict 'refs';

4104

${join('::', ref($safeObject) ? $safeObject->root : 'main', 'PerlPoint')}=dclone($flags{activeBaseData});

4105

}

4106

4107

# evaluate the source code (for an unknown reason, we have to precede the constant by "&" here to work)

4108

warn "[Info] Evaluating included Perl code.\n" unless $flags{display} & &DISPLAY_NOINFO;

4109

100

my $result=ref($safeObject) ? $safeObject->rdo($tagpars{file})

4110

: eval

4111

{

4112

# enter user code namespace

4113

325

package main;

354271

4114

# disable "strict" checks

4115

916

no strict;

4116

# excute user code

4117

6251

my $result=do $tagpars{file};

4118

# check result ($! does not need to be checked, we checked file readability ourselves before)

4119

die $@ if $@;

4120

# reply provided result

4121

$result;

4122

};

4123

793

4124

# check result

4125

if ($@)

4126

{_semerr($_[0], "$sourceFile, line $_[3][1]: included Perl code could not be evaluated: $@.");}

4127

else

4128

100

{

4129

# success - make the result part of the input stream (by stack)

4130

_stackInput($_[0], split(/(\n)/, $result)) if defined $result;

4131

4132

# reset the "end of input reached" flag if necessary

4133

$readCompletely=0 if $readCompletely;

4134

}

4135

}

4136

4137

# we have to supply something, but it should be nothing

4138

[[()], $_[3][1]];

4139

}

4140

else

4141

{

4142

# we include anything else: provide the contents as it is,

4143

# declared as an "embedded" part

4144

291

# open(my $included, $tagpars{file});

4145

my $included=new IO::File;

4146

open($included, $tagpars{file});

4147

my @included=<$included>;

4148

close($included);

4149

4150

100

# in case the file was declared a (parsed) example, embed its contents as a (verbatim) block,

4151

# otherwise, include it as really embedded part (to be processed by a backend)

4152

if ($tagpars{type}=~/^(parsed)?example$/i)

4153

{

4154

# set paragraph type

4155

my $ptypeDirective=defined($1) ? DIRECTIVE_BLOCK : DIRECTIVE_VERBATIM;

4156

4157

# indent lines, if requested

4158

if (exists $tagpars{indent})

4159

{

4160

# check parameter

4161

unless ($tagpars{indent}=~/^\d+$/)

4162

{$errors++, _semerr($_[0], "$sourceFile, line $_[3][1]: Invalid indentation value of \"$tagpars{indent}\", please set up a number.");}

4163

else

4164

{

4165

# all right, indent

4166

my $indentation=' ' x $tagpars{indent};

4167

@included=map {"$indentation$_"} @included;

4168

}

4169

}

4170

4171

my %hints=(nr=>++$directiveCounter);

4172

[

4173

[

4174

# opener directive

4175

[\%hints, $ptypeDirective, DIRECTIVE_START],

4176

# the list of enclosed literals

4177

@included,

4178

# final directive

4179

[\%hints, $ptypeDirective, DIRECTIVE_COMPLETE]

4180

4181

$_[3][1]

4182

];

4183

}

4184

else

4185

{

4186

my %hints=(nr=>++$directiveCounter);

4187

[

4188

[

4189

# opener directive

4190

[\%hints, DIRECTIVE_TAG, DIRECTIVE_START, 'EMBED', {lang=>$tagpars{type}}],

4191

# the list of enclosed "literals", if any

4192

@included,

4193

# final directive

4194

[\%hints, DIRECTIVE_TAG, DIRECTIVE_COMPLETE, 'EMBED', {lang=>$tagpars{type}}]

4195

4196

$_[3][1]

4197

];

4198

}

4199

}

4200

}

4201

else

4202

{

4203

# file missing, simply inform user

4204

$errors++, _semerr($_[0], "$sourceFile, line $_[3][1]: File $tagpars{file} does not exist or cannot be read (current directory: ", cwd(), ").");

4205

4206

# we have to supply something, but it should be nothing

4207

[[()], $_[3][1]];

4208

}

4209

}

4210

else

4211

{

4212

# we have to supply something, but it should be nothing

4213

[[()], $_[3][1]];

4214

}

4215

}

4216

;

4217

4218

4219

# macro definition

4220

alias_definition : '+'

4221

{

4222

# switch to definition mode

4223

_stateManager(STATE_DEFINITION);

4224

4225

# trace, if necessary

4226

warn "[Trace] $sourceFile, line $_[1][1]: Macro definition starts.\n" if $flags{trace} & TRACE_PARAGRAPHS;

4227

}

4228

Word

4229

{

4230

# deactivate boost

4231

$flags{noboost}=1;

4232

}

4233

optional_tagpars

4234

{

4235

# reactivate boost

4236

$flags{noboost}=0;

4237

}

4238

Colon

4239

{

4240

# disable all specials to get the body as a plain text

4241

@specials{keys %specials}=(0) x scalar(keys %specials);

4242

}

4243

text

4244

{

4245

# "text" already switched back to default mode (and disabled specials [{}:])

4246

4247

# trace, if necessary

4248

warn "[Trace] $sourceFile, line $_[7][1]: Macro definition completed.\n" if $flags{trace} & TRACE_PARAGRAPHS;

4249

4250

# check spelling (only accept capitals and underscores in alias names, just like in tags)

4251

if ($_[3][0]=~/[a-z]/)

4252

{

4253

warn "[Warn] $sourceFile, line $_[3][1]: Macro \"\\$_[3][0]\" is stored as ", uc("\\$_[3][0]"), ".\n" unless $flags{display} & DISPLAY_NOWARN;

4254

$_[3][0]=uc($_[3][0]);

4255

}

4256

4257

# build macro text

4258

shift(@{$_[9][0]}); pop(@{$_[9][0]});

4259

my $macro=join('', @{$_[9][0]});

4260

4261

# anything specified?

4262

if ($macro=~/^\s*$/)

4263

{

4264

# nothing defined, should this line cancel a previous definition?

4265

if (exists $macros{$_[3][0]})

4266

{

4267

# cancel macro

4268

delete $macros{$_[3][0]};

4269

4270

# trace, if necessary

4271

warn "[Trace] $sourceFile, line $_[7][1]: Macro \"$_[3][0]\" is cancelled.\n" if $flags{trace} & TRACE_SEMANTIC;

4272

4273

# update macro checksum

4274

$macroChecksum=sha1_base64(nfreeze(\%macros));

4275

}

4276

else

4277

{

4278

# trace, if necessary

4279

warn "[Trace] $sourceFile, line $_[7][1]: Empty macro \"$_[3][0]\" is ignored.\n" if $flags{trace} & TRACE_SEMANTIC;

4280

}

4281

}

4282

else

4283

{

4284

# ok, this is a new definition - get all used parameters

4285

my %pars;

4286

@pars{($macro=~/__([^_\\]+)__/g)}=();

4287

100

4288

# store default values of options, if necessary

4289

if (@{$_[5][0]})

4290

{

4291

# the list already consists of key/value pairs

4292

my %defaults=@{$_[5][0]};

4293

exists $pars{$_} and $pars{$_}=$defaults{$_} for keys %defaults;

4294

}

4295

100

4296

# tag body wildcard is no parameter

4297

my $bodyFlag=exists $pars{body} ? 1 : 0;

4298

delete $pars{body};

4299

4300

# make guarded underscores just underscores

4301

$macro=~s/\\_//g;

4302

4303

# store name, parameters (and their defaults, if any),

4304

# macro text and body flag

4305

$macros{$_[3][0]}=[\%pars, $macro, $bodyFlag];

4306

4307

# update macro checksum

4308

$macroChecksum=sha1_base64(nfreeze(\%macros));

4309

}

4310

4311

493

# we have to supply something, but it should be nothing

4312

# (this is a paragraph, so reply a plain string)

4313

49098

['', $_[11][1]];

4314

}

4315

;

4316

952

4317

4318

4319

4320

4321

4322

# ------------------------------------------

4323

# Internal function: input stack management.

4324

# ------------------------------------------

4325

sub _stackInput

4326

{

4327

# get parameters

4328

my ($parser, @lines)=@_;

4329

4330

# declare variable

4331

my (@waiting);

4332

4333

# the current input line becomes the last line to read in this set

4334

100

196

# (this way, we arrange it that additional text is exactly placed where its generator tag or macro stood,

4335

# without Ils confusion)

4336

push(@lines, (defined $parser->{USER}->{INPUT} and $parser->{USER}->{INPUT}) ? $parser->{USER}->{INPUT} : ());

4337

4338

# combine line parts to lines completed by a trailing newline

4339

# (additionally, take into account that there might be mixed references which have to be stored unchanged)

171

4340

{

4341

my $lineBuffer='';

4342

100

134

foreach my $line (@lines)

4343

{

4344

if (ref($line))

4345

{

4346

# push collected string and current reference

4347

push(@waiting, length($lineBuffer) ? $lineBuffer : (), $line);

4348

4349

# reset line buffer

4350

$lineBuffer='';

4351

4352

# next turn

4353

next;

4354

}

4355

4356

# compose a string ...

4357

$lineBuffer.=$line;

4358

100

142

4359

# ... until a newline was found

4360

100

102

push(@waiting, $lineBuffer), $lineBuffer='' if $line eq "\n";

4361

}

4362

push(@waiting, $lineBuffer) if length($lineBuffer);

4363

}

4364

4365

# get next line to read

4366

my $newInputLine=shift(@waiting);

4367

4368

# update (innermost) input stack

4369

unshift(@{$inputStack[0]}, @waiting);

4370

105

4371

# update line memory (flag that this was an expanded line by adding a third parameter)

4372

unshift(@inLine, [length($newInputLine)+length('exp.: '), "exp.: $newInputLine", 1]);

4373

4374

# make the new top line the current input

4375

$parser->{USER}->{INPUT}=$newInputLine;

4376

}

4377

4378

4379

4380

# a pattern lookup table for certain specials, used by the lexer (should be scoped to it

4381

# but indentation of a long function takes time ...)

4382

my %specials2patterns;

4383

@specials2patterns{'colon', 'number', '-'}=(':', '0-9', '\-');

4384

4385

4386

# -----------------------------

4387

# Internal function: the lexer.

4388

# -----------------------------

4389

sub _lexer

4390

5882

13459

{

4391

# get parameters

4392

my ($parser)=@_;

4393

5882

100

46510

4394

# scan for unlexed EOL�s which should be ignored

4395

while (

4396

$parser->{USER}->{INPUT}

4397

and $parser->{USER}->{INPUT}=~/^\n/

4398

and (

4399

$lexerFlags{eol}==LEXER_IGNORE

4400

or (

4401

@tableSeparatorStack

4402

and $tableSeparatorStack[0][1] eq "\n"

4403

and $tableColumns<0

4404

)

4405

)

4406

)

4407

{

4408

# trace, if necessary

4409

warn "[Trace] Lexer: Ignored EOL in line $lineNrs{$inHandle}.\n" if $flags{trace} & TRACE_LEXER;

4410

4411

# remove the ignored newline

4412

$parser->{USER}->{INPUT}=~s/^\n//;

4413

123

4414

# update column counter, if necessary

4415

$tableColumns++ if @tableSeparatorStack and $tableSeparatorStack[0][1] eq "\n" and $tableColumns<0;

4416

}

4417

5882

100

18087

4418

# get next symbol

4419

unless ($parser->{USER}->{INPUT})

4420

{

4421

1681

100

2202

# update line memory (removed handled lines, both original and expanded ones)

169

1685

7593

4422

# (use a do block to perform the operation once in any case, see perlsyn)

4423

do {shift(@inLine)} until not @inLine or @{$inLine[0]}==2;

4424

4425

1681

7841

{

2091

2514

2091

4110

4426

# will the next line be get from the input stack instead of from a real file?

4427

my $lineFromStack=scalar(@{$inputStack[0]});

4428

2091

100

6232

4429

# reset stack line buffer, if necessary

4430

undef @previousStackLines unless $lineFromStack;

4431

2091

100

3029

4432

2091

29540

# get next input line

4433

unless (

4434

(@{$inputStack[0]} and ($parser->{USER}->{INPUT}=shift(@{$inputStack[0]}) or 1))

4435

or (defined($inHandle) and $parser->{USER}->{INPUT}=<$inHandle>)

4436

)

4437

100

310

{

4438

# was this a nested source?

4439

unless (@inHandles)

4440

{

4441

# This was the base document: should we insert a final additional token?

4442

# (In case we recognize the end of a document source when there is still a

4443

# paragraph filter pending, supply as many "empty lines" as necessary to let

4444

100

1189

# the parser recognize the filtered paragraph is completed. Possibly a loop

4445

# detection should be added to avoid endless ping-pong.)

4446

$readCompletely=1,

4447

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Final Empty_line in line $lineNrs{$inHandle}.\n")),

4448

return('Empty_line', ['', $lineNrs{$inHandle}]) unless $readCompletely and not $flags{virtualParagraphStart};

4449

255

4450

# well done

4451

return('', [undef, -1]);

4452

}

4453

else

4454

{

4455

# we finished a nested source: close it and restore

4456

# things to continue reading of enclosing file

4457

129

my ($helper1, $helper2, $helper3, $localizedVars, $localizedAll);

4458

(

4459

$helper1,

4460

$parser->{USER}->{INPUT},

4461

$sourceFile,

4462

$helper2,

4463

@flags{qw(headlineLevelOffset headlineLevel)},

4464

$helper3,

4465

$localizedVars, $localizedAll,

4466

)=@{shift(@inHandles)};

4467

$lineNrs{$inHandle}=$helper2-1; # -1 to compensate the subsequent increment

4468

560

4469

# back to envelopes directory

4470

chdir($helper3);

4471

512

4472

486

# reopen envelope file

4473

1855

close($inHandle);

4474

$inHandle=new IO::File;

4475

open($inHandle, $sourceFile);

4476

binmode($inHandle);

4477

seek($inHandle, $helper1, 0);

4478

4479

# switch back to envelopes input stack

4480

shift(@inputStack);

4481

4482

# update nesting stack

4483

pop(@nestedSourcefiles);

4484

162

4485

# update source file nesting level hint

4486

_predeclareVariables({_SOURCE_LEVEL=>scalar(@nestedSourcefiles)});

4487

100

224

100

4488

# restore variables as necessary

4489

if ($localizedAll)

4490

{

4491

# Do we have to take care of the stream?

4492

if ($flags{var2stream})

4493

{

4494

# stream variable reset

4495

push(@{$resultStreamRef->[STREAM_TOKENS]}, [{}, DIRECTIVE_VARRESET, DIRECTIVE_START]);

4496

4497

# update tag finish memory

4498

_updateTagFinishMem(scalar(@{$resultStreamRef->[STREAM_TOKENS]}));

4499

4500

# restore former variables completely, overwriting current settings

4501

# (and propagating them into the stream again)

4502

undef %variables;

4503

_predeclareVariables({$_=>$localizedVars->{$_}}, 1) foreach sort keys %$localizedVars;

4504

}

4505

else

4506

{

4507

# ok, the stream does not take notice of this operation, so it can be performed quicker

4508

%variables=%$localizedVars;

4509

}

4510

}

4511

elsif (!$localizedAll and %$localizedVars)

4512

{

4513

# handle each localized variable

4514

foreach my $var (keys %$localizedVars)

4515

{

4516

# restore old value in parser and stream context, if necessary

4517

_predeclareVariables({$var=>$localizedVars->{$var}}, 1)

4518

if $localizedVars->{$var} ne $variables{$var};

4519

}

4520

}

4521

}

4522

}

4523

2024

100

4748

4524

# update stack line buffers, if necessary

4525

if ($lineFromStack)

4526

{

4527

# "rotate" buffers (necessary because there are various return points following,

4528

# so there will be not exactly one final point where we could save the current

4529

# line value in a scalar buffer)

4530

$previousStackLines[0]=$previousStackLines[1];

4531

$previousStackLines[1]=$parser->{USER}->{INPUT};

4532

}

4533

2024

100

4932

4534

# reference found on stack?

4535

if ($lineFromStack and ref($parser->{USER}->{INPUT}))

4536

{

4537

# get the reference

4538

my @refLexed=_refLexed($parser);

4539

4540

# unless the item was a newline, we can use it directly

4541

100

# (but the context for newline evaluation might have changed between the

4542

# point of delaying and now)

4543

return @refLexed unless $refLexed[0] eq 'Empty_line';

4544

4545

# ok, this has to be parsed *again* (because the paragraph/special characters

4546

# context *now* might be different from that that was present when we stacked

4547

# the item)

4548

($parser->{USER}->{INPUT}, $lineNrs{$inHandle})=@{$refLexed[1]};

4549

}

4550

2014

100

6734

4551

# update line counter, if necessary

4552

$lineNrs{$inHandle}++ unless $lineFromStack;

4553

2014

100

7229

4554

1995

100

5949

# ignore this line if wished (take conditions and docstreams into account)

4555

$parser->{USER}->{INPUT}='', redo if $flags{skipInput}==1 and $parser->{USER}->{INPUT}!~/^\?/;

4556

$parser->{USER}->{INPUT}='', redo if $flags{skipInput}==2 and $parser->{USER}->{INPUT}!~/^[~=]/;

4557

1924

3125

4558

# if we are here, we can leave the skip mode (both condition and docstream one)

4559

$flags{skipInput}=0;

4560

1924

9638

4561

# we read a new line (or something from stack)

4562

1924

100

11489

unshift(@inLine, [length($parser->{USER}->{INPUT})+length('org.: '), "org.: $parser->{USER}->{INPUT}"]);

4563

4564

unless ($lineFromStack)

4565

1913

100

4626

{

4566

# add a line update hint

4567

if ($flags{linehints})

4568

{

4569

push(@{$resultStreamRef->[STREAM_TOKENS]}, [{}, DIRECTIVE_NEW_LINE, DIRECTIVE_START, {file=>$sourceFile, line=>$lineNrs{$inHandle}}]);

4570

608

4571

# update tag finish memory by the way

4572

_updateTagFinishMem(scalar(@{$resultStreamRef->[STREAM_TOKENS]}));

4573

}

4574

4575

1913

9015

# remove TRAILING whitespaces, but keep newlines (if any)

1913

9240

4576

1913

14906

{

4577

1913

100

9701

my $newline=($parser->{USER}->{INPUT}=~/\n$/m);

4578

$parser->{USER}->{INPUT}=~s/\s*$//;

4579

$parser->{USER}->{INPUT}=join('', $parser->{USER}->{INPUT}, "\n") if $newline;

4580

}

4581

}

4582

1924

100

6429

4583

# scan for empty lines as necessary

4584

if ($parser->{USER}->{INPUT}=~/^$/)

4585

867

100

2969

{

4586

# update the checksum flags

4587

$flags{checksum}=1 if $flags{cache} & CACHE_ON;

4588

867

2441

4589

# trace, if necessary

4590

warn "[Trace] Lexer: Empty_line in line $lineNrs{$inHandle}", $lexerFlags{el}==LEXER_IGNORE ? ' is ignored' : '', ".\n" if $flags{trace} & TRACE_LEXER;

4591

867

3413

4592

# update input line

4593

$parser->{USER}->{INPUT}='';

4594

867

100

2940

4595

# sometimes empty lines have no special meaning

4596

shift(@inLine), redo if $lexerFlags{el}==LEXER_IGNORE;

4597

547

5033

4598

# but sometimes they are very special

4599

return('Empty_line', ["\n", $lineNrs{$inHandle}]);

4600

}

4601

else

4602

1057

100

3010

{

4603

# disable caching for embedded code containing empty lines

4604

$flags{checksummed}=0 if $specials{embedded};

4605

1057

100

5378

100

4606

# this may be the first line of a new paragraph to be checksummed

4607

if (

4608

($flags{cache} & CACHE_ON)

4609

and $flags{checksum}

4610

and not $lineFromStack

4611

and (not $specials{heredoc} or $specials{heredoc} eq '1')

4612

and not @tableSeparatorStack

4613

and not $specials{embedded}

4614

)

4615

104

439

{

4616

# handle $/ locally

4617

local($/);

4618

104

232

4619

# update statistics

4620

$statistics{cache}[0]++;

4621

104

100

587

100

4622

# well, switch to paragraph mode (depending on the paragraph type)!

4623

if ($parser->{USER}->{INPUT}=~/^<<(\w+)/)

4624

251

{$/="\n$1";}

4625

elsif ($parser->{USER}->{INPUT}=~/^(?

4626

{$/="\n\\END_TABLE";}

4627

else

4628

{$/='';}

4629

104

245

4630

# store current position

4631

my $lexerPosition=tell($inHandle);

4632

104

100

2269

4633

104

2914

# read *current* paragraph completely (take care - we may have read it completely yet!)

4634

104

100

836

seek($inHandle, $lexerPosition-length($parser->{USER}->{INPUT}), 0) unless $parser->{USER}->{INPUT}=~/^<<(\w+)/ or $parser->{USER}->{INPUT}=~/^(?

4635

my $paragraph=<$inHandle>;

4636

$paragraph=join('', $parser->{USER}->{INPUT}, $paragraph) if $parser->{USER}->{INPUT}=~/^<<(\w+)/ or $parser->{USER}->{INPUT}=~/^(?

4637

104

166

4638

104

32232

# count the lines in the paragraph read

4639

104

100

908

my $plines=0;

4640

$plines++ while $paragraph=~/(\n)/g;

4641

$plines-- unless $parser->{USER}->{INPUT}=~/^<<(\w+)/ or $parser->{USER}->{INPUT}=~/^(?

4642

104

4574

4643

# remove trailing whitespaces (to avoid checksumming them)

4644

$paragraph=~s/\n+$//;

4645

104

480

4646

# anything interesting found?

4647

if (defined $paragraph)

4648

104

4375

{

4649

# build checksum (of paragraph *and* headline level offset)

4650

my $checksum=sha1_base64(join('+', exists $flags{headlineLevelOffset} ? $flags{headlineLevelOffset} : 0, $paragraph));

4651

4652

104

100

1040

# warn "---> Searching checksum for this paragraph:\n-----\n$paragraph\n- by $checksum --\n";

4653

# check paragraph to be known

4654

if (

4655

exists $checksums->{$sourceFile}

4656

and exists $checksums->{$sourceFile}{$checksum}

4657

and (

4658

not defined $checksums->{$sourceFile}{$checksum}[3]

4659

or $checksums->{$sourceFile}{$checksum}[3] eq $macroChecksum

4660

)

4661

and (

4662

not defined $checksums->{$sourceFile}{$checksum}[4]

4663

or $checksums->{$sourceFile}{$checksum}[4] eq $varChecksum

4664

)

4665

)

4666

{

4667

# Do *not* reset the checksum flag for new checksums - we already read the

4668

# empty lines, and a new paragraph may follow! *But* deactivate the current

4669

# checksum to avoid multiple storage - we already stored it, right?

4670

$flags{checksummed}=0;

4671

4672

# reset input buffer - it is all handled (take care to remove a final newline

4673

# if the paragraph was closed by a string - this would normally be read in a

4674

# per line processing, but it remained in the file in paragraph mode)

4675

$/="\n";

4676

scalar(<$inHandle>) if $parser->{USER}->{INPUT}=~/^<<(\w+)/ or $parser->{USER}->{INPUT}=~/^(?

4677

$parser->{USER}->{INPUT}='';

4678

4679

# warn "===========> PARAGRAPH CACHE HIT!! ($lineNrs{$inHandle}/$sourceFile/$checksum) <=================\n$paragraph-----\n";

4680

# use Data::Dumper; warn Dumper($checksums->{$sourceFile}{$checksum});

4681

4682

# update statistics

4683

$statistics{cache}[1]++;

4684

4685

# update line counter

4686

# warn "----> Old line: $lineNrs{$inHandle}\n";

4687

$lineNrs{$inHandle}+=$plines;

4688

# warn "----> New line: $lineNrs{$inHandle}\n";

4689

4690

# update anchors

4691

$anchors->add($_, $checksums->{$sourceFile}{$checksum}[5]{$_}, $flags{headlinenr})

4692

foreach keys %{$checksums->{$sourceFile}{$checksum}[5]};

4693

4694

# The next steps depend - follow the provided hint. We may have to reinvoke

4695

# the parser to restore a state.

4696

# perl 5.6 # unless (exists $checksums->{$sourceFile}{$checksum}[2])

4697

unless (defined $checksums->{$sourceFile}{$checksum}[2])

4698

{

4699

# direct case - add the already known part directly to the stream

4700

push(@{$resultStreamRef->[STREAM_TOKENS]}, @{$checksums->{$sourceFile}{$checksum}[0]});

4701

4702

# update tag finish memory

4703

_updateTagFinishMem(scalar(@{$resultStreamRef->[STREAM_TOKENS]}));

4704

4705

# Well done this paragraph - go on!

4706

shift(@inLine);

4707

redo;

4708

}

4709

else

4710

{

4711

# more complex case - reinvoke the parser to update its states

4712

return($checksums->{$sourceFile}{$checksum}[2], [dclone($checksums->{$sourceFile}{$checksum}[0]), $lineNrs{$inHandle}]);

4713

}

4714

}

4715

104

191

104

490

4716

# flag that we are going to build an associated stream

4717

$flags{checksummed}=[$checksum, scalar(@{$resultStreamRef->[STREAM_TOKENS]}), $plines];

4718

# warn "---> Started checksumming for\n-----\n$paragraph\n---(", $plines+1, " line(s))\n";

4719

104

680

4720

# restart anchor logging

4721

$anchors->checkpoint(1);

4722

}

4723

104

1011

4724

# reset file pointer

4725

seek($inHandle, $lexerPosition, 0);

4726

}

4727

4728

1057

2392

# update the checksum flag: we are *within* a paragraph, do not checksum

4729

# until we reach the next empty line

4730

$flags{checksum}=0;

4731

}

4732

4733

1057

100

3587

# detect things at the beginning of a *real* line at the beginning of a paragraph

4734

# (which nevertheless might have been stacked)

4735

if ( not $lineFromStack

4736

or ( defined $previousStackLines[0]

4737

and not ref($previousStackLines[0])

4738

and $previousStackLines[0]=~/\n$/

4739

)

4740

1048

3322

)

4741

1048

100

4048

{

4742

my @rc=_lineStartResearch($parser);

4743

return(@rc) if shift(@rc);

4744

}

4745

}

4746

}

4747

5233

21309

4748

# trace, if necessary

4749

warn '[Trace] Lexing ', ref($parser->{USER}->{INPUT}) ? 'a prepared part' : qq("$parser->{USER}->{INPUT}"), ".\n" if $flags{trace} & TRACE_LEXER;

4750

5233

14404

4751

# Reference found? (Usually placed by _stackInput().)

4752

return _refLexed($parser) if ref($parser->{USER}->{INPUT});

4753

4754

5233

100

13985

# if the paragraph was just filtered, there might be certain operations to perform

4755

# (as usual at the beginning of a new paragraph)

4756

if ($parserState==STATE_PFILTERED)

4757

100

{

4758

my @rc=_lineStartResearch($parser);

4759

return(@rc) if shift(@rc);

4760

}

4761

5229

100

19164

100

4762

# scan for heredoc close hints

4763

if ($specials{heredoc} and $specials{heredoc} ne '1' and $parser->{USER}->{INPUT}=~/^($specials{heredoc})$/)

4764

{

4765

# trace, if necessary

4766

warn "[Trace] Lexer: Heredoc close hint $1 in line $lineNrs{$inHandle}.\n" if $flags{trace} & TRACE_LEXER;

4767

4768

# update input line

4769

$parser->{USER}->{INPUT}='';

4770

4771

# reset heredoc setting

4772

$specials{heredoc}=1;

4773

110

4774

# reply token

4775

return('Heredoc_close', [$1, $lineNrs{$inHandle}]);

4776

}

4777

5217

100

29888

100

4778

# can we take the rest of the line at *once*?

4779

if (($parserState==STATE_COMMENT or $parserState==STATE_VERBATIM) and $parser->{USER}->{INPUT} ne "\n")

4780

156

{

4781

100

157

# grab line and chomp if necessary

4782

my $line=$parser->{USER}->{INPUT};

4783

chomp($line) unless $parserState==STATE_VERBATIM;

4784

100

188

4785

# update input line (restore trailing newline if it will be used to detect paragraph completion)

4786

$parser->{USER}->{INPUT}=$parserState==STATE_VERBATIM ? '' : "\n";

4787

176

4788

# trace, if necessary

4789

warn qq([Trace] Lexer: word "$line" in line $lineNrs{$inHandle}.\n) if $flags{trace} & TRACE_LEXER;

4790

437

4791

# supply result

4792

return('Word', [$line, $lineNrs{$inHandle}]);

4793

}

4794

5141

13503

4795

# reply a token

4796

for ($parser->{USER}->{INPUT})

4797

5141

15047

{

4798

# declare scopies

4799

my ($found, $sfound);

4800

5141

100

11079

4801

# check for table separators, if necessary (these are the most common strings)

4802

if (@tableSeparatorStack)

4803

389

100

3479

{

4804

# check for a column separator

4805

s/^$tableSeparatorStack[0][0]//,

4806

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: table column separator in line $lineNrs{$inHandle}.\n")),

4807

return('Table_separator', ['c', $lineNrs{$inHandle}]) if /^($tableSeparatorStack[0][0])/;

4808

305

100

2296

4809

# check for row separator

4810

s/^$tableSeparatorStack[0][1]//,

4811

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: table row separator in line $lineNrs{$inHandle}.\n")),

4812

return('Table_separator', ['r', $lineNrs{$inHandle}]) if /^($tableSeparatorStack[0][1])/;

4813

}

4814

5007

100

12865

4815

# reply next token: EOL?

4816

889

100

9746

if (/^(\n)/)

100

4817

{

4818

277

693

if ($lexerFlags{eol}==LEXER_TOKEN)

4819

277

730

{

4820

277

1411

$found=$1;

4821

277

3956

warn("[Trace] Lexer: EOL in line $lineNrs{$inHandle}.\n") if $flags{trace} & TRACE_LEXER;

4822

s/^$1//;

4823

return('EOL', [$found, $lineNrs{$inHandle}]);

4824

}

4825

elsif ($lexerFlags{eol}==LEXER_EMPTYLINE)

4826

161

{

4827

309

# flag "empty line" as wished

4828

357

warn("[Trace] Lexer: EOL -> Empty_line in line $lineNrs{$inHandle}.\n") if $flags{trace} & TRACE_LEXER;

4829

s/^$1//;

4830

return('Empty_line', ['', $lineNrs{$inHandle}]);

4831

}

4832

elsif ($lexerFlags{eol}==LEXER_SPACE)

4833

563

2205

{

4834

563

3511

# flag "space" as wished and reply a simple whitespace

4835

563

8011

warn("[Trace] Lexer: EOL -> Space in line $lineNrs{$inHandle}.\n") if $flags{trace} & TRACE_LEXER;

4836

s/^$1//;

4837

return('Space', [' ', $lineNrs{$inHandle}]);

4838

}

4839

else

4840

{die "[BUG] Unhandled EOL directive $lexerFlags{eol}.";}

4841

}

4842

4118

10381

4843

# reply next token: scan for Ils if necessary

4844

$found=$1, s/^$1//,

4845

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Ils in line $lineNrs{$inHandle}.\n")),

4846

return('Ils', [$found, $lineNrs{$inHandle}]) if $parserState==STATE_PFILTERED and /^$lexerPatterns{space}/;

4847

4118

100

34253

4848

# reply next token: scan for spaces

4849

$found=$1, s/^$1//,

4850

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Space in line $lineNrs{$inHandle}.\n")),

4851

return('Space', [$found, $lineNrs{$inHandle}]) if /^$lexerPatterns{space}/;

4852

3671

100

25217

100

4853

# reply next token: scan for paragraph filter delimiters ("||" and "|")

4854

$found=$1, s/^\Q$1//,

4855

(($flags{trace} & TRACE_LEXER) and warn(qq([Trace] Lexer: Paragraph filter delimiter "$found" in line $lineNrs{$inHandle}.\n))),

4856

return($found, [$found, $lineNrs{$inHandle}]) if /^$lexerPatterns{pfilterDelimiter}/ and $specials{pfilter};

4857

3655

100

10358

4858

# reply next token: scan for here doc openers

4859

$found=$1, s/^<<$1//,

4860

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Heredoc opener $found in line $lineNrs{$inHandle}.\n")),

4861

return('Heredoc_open', [$found, $lineNrs{$inHandle}]) if /^<<(\w+)/ and $specials{heredoc} eq '1';

4862

3643

100

24653

100

4863

# reply next token: scan for SPECIAL tagnames: \TABLE

4864

$found=$1, s/^\\$1//,

4865

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Table starts in line $lineNrs{$inHandle}.\n")),

4866

return('Table', [$found, $lineNrs{$inHandle}]) if $specials{tag} and /^$lexerPatterns{table}/;

4867

3632

100

20279

100

4868

# reply next token: scan for SPECIAL tagnames: \END_TABLE

4869

$found=$1, s/^\\$1//,

4870

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Table completed in line $lineNrs{$inHandle}.\n")),

4871

return('Tabled', [$found, $lineNrs{$inHandle}]) if $specials{tag} and /^$lexerPatterns{endTable}/;

4872

3621

100

20607

100

4873

# reply next token: scan for SPECIAL tagnames: \EMBED

4874

$found=$1, s/^\\$1//,

4875

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Embedding starts in line $lineNrs{$inHandle}.\n")),

4876

return('Embed', [$found, $lineNrs{$inHandle}]) if $specials{tag} and /^$lexerPatterns{embed}/;

4877

3593

100

21628

100

4878

# reply next token: scan for SPECIAL tagnames: \END_EMBED

4879

$found=$1, s/^\\$1//,

4880

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Embedding completed in line $lineNrs{$inHandle}.\n")),

4881

return('Embedded', [$found, $lineNrs{$inHandle}]) if $specials{embedded} and /^$lexerPatterns{endEmbed}/;

4882

3565

100

21423

100

4883

# reply next token: scan for SPECIAL tagnames: \INCLUDE

4884

$found=$1, s/^\\$1//,

4885

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Including starts in line $lineNrs{$inHandle}.\n")),

4886

return('Include', [$found, $lineNrs{$inHandle}]) if $specials{tag} and /^$lexerPatterns{include}/;

4887

3548

100

34296

100

4888

# reply next token: scan for tagnames

4889

$found=$1, s/^\\$1//,

4890

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Tag opener $found in line $lineNrs{$inHandle}.\n")),

4891

return('Tag_name', [$found, $lineNrs{$inHandle}]) if $specials{tag} and /^$lexerPatterns{tag}/ and (exists $tagsRef->{$1} or exists $macros{$1});

4892

3436

100

56701

100

4893

# reply next token: scan for special characters

4894

$found=$1, s/^\Q$1//,

4895

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Special $found in line $lineNrs{$inHandle}.\n")),

4896

return($found, [$found, $lineNrs{$inHandle}]) if /^$patternNlbBackslash(\S)/ and exists $specials{$1} and $specials{$1};

4897

2505

100

10417

100

4898

# reply next token: scan for definition list items

4899

$found=$1, s/^$1//,

4900

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Colon in line $lineNrs{$inHandle}.\n")),

4901

return('Colon', [$found, $lineNrs{$inHandle}]) if $specials{colon} and /^$lexerPatterns{colon}/;

4902

4903

2486

100

30940

# reply next token: search for named variables (which need to be defined except at the

100

4904

# beginning of a new assignment paragraph)

4905

$found=$1, s/^\$$1//,

4906

(($flags{trace} & TRACE_LEXER) and warn(qq([Trace] Lexer: Named variable "$found" in line $lineNrs{$inHandle}.\n))),

4907

return('Named_variable', [$found, $lineNrs{$inHandle}])

4908

if /^$lexerPatterns{namedVar}(=?)/

4909

and (

4910

($parserState==STATE_DEFAULT and defined($2))

4911

or exists $variables{$1}

4912

);

4913

4914

2314

100

13793

# reply next token: search for symbolic variables (these cannot be used in assignments,

100

4915

# so handling is easier)

4916

$found=$2, s/^\$$1//,

4917

(($flags{trace} & TRACE_LEXER) and warn(qq([Trace] Lexer: Symbolic variable "$found" in line $lineNrs{$inHandle}.\n))),

4918

return('Symbolic_variable', [$found, $lineNrs{$inHandle}])

4919

if /^$lexerPatterns{symVar}/ and exists $variables{$2};

4920

4921

# flag that this paragraph *might* use macros someday, if there is still something being no tag and no

4922

2271

100

14355

# macro, but looking like a tag or a macro (somebody could *later* declare it a real macro, so the cache

100

4923

# needs to check macro definitions)

4924

$flags{checksummed}[3]=1

4925

if $specials{tag} and /^$lexerPatterns{tag}/

4926

and not (exists $flags{checksummed} and not $flags{checksummed});

4927

4928

# likewise, flag that this paragraph *might* use variables someday, if there is still something being no variable,

4929

2271

100

35234

# but looking like a variable (somebody could *later* declare it a real var, so the cache

100

4930

# needs to check variable definitions)

4931

$flags{checksummed}[4]=1

4932

if /($lexerPatterns{namedVarKernel})|($lexerPatterns{symVarKernel})/

4933

and not (exists $flags{checksummed} and not $flags{checksummed});

4934

2271

100

24242

100

4935

# remove guarding \\, if necessary

4936

s/^\\// unless $specials{heredoc}

4937

or (defined $lexerFlags{backsl} and $lexerFlags{backsl}==LEXER_TOKEN)

4938

or $parserState==STATE_EMBEDDING

4939

or $parserState==STATE_PFILTER

4940

or $parserState==STATE_CONDITION

4941

or $parserState==STATE_DEFINITION;

4942

2271

100

7139

4943

# reply next token: scan for numbers, if necessary

4944

$found=$1, s/^$1//,

4945

(($flags{trace} & TRACE_LEXER) and warn("[Trace] Lexer: Number $found in line $lineNrs{$inHandle}.\n")),

4946

2269

100

5460

return('Number', [$found, $lineNrs{$inHandle}]) if $specials{number} and /^(\d+)/;

4947

4948

unless ($flags{noboost})

4949

1871

100

80973

{

3058

8069

4950

1871

100

11018

# build set of characters to be special

4951

1871

100

6715

my $special=join('', '([', (map {exists $specials2patterns{$_} ? $specials2patterns{$_} : $_} grep(($specials{$_} and (length==1 or exists $specials2patterns{$_})), keys %specials)), '\n\\\\', '])');

4952

1871

111359

$special=qr($special|(\|{1,2})) if $specials{pfilter};

4953

$special=qr($special|($tableSeparatorStack[0][0])|($tableSeparatorStack[0][1])) if @tableSeparatorStack;

4954

$special=qr($special|(($lexerPatterns{namedVar})|($lexerPatterns{symVar})));

4955

4956

# reply next token: scan for word or single character (declared as "Word" as well)

4957

1871

100

212007

#warn("~~~~~~~~~> $special\n");

4958

#warn("---------> $_");

4959

$found=$1, s/^\Q$1//,

4960

#warn("=====> $found\n\n"),

4961

(($flags{trace} & TRACE_LEXER) and warn(qq([Trace] Lexer: (Boosted) word "$found" in line $lineNrs{$inHandle}.\n))),

4962

return('Word', [$found, $lineNrs{$inHandle}])

4963

if $_!~/^$special/ and /^(.+?)($special|($))/;

4964

}

4965

712

45005

4966

# reply next token: scan for word or single character (declared as "Word" as well)

4967

$found=$1, s/^\Q$1//,

4968

(($flags{trace} & TRACE_LEXER) and warn(qq([Trace] Lexer: Word "$found" in line $lineNrs{$inHandle}.\n))),

4969

return('Word', [$found, $lineNrs{$inHandle}]) if /^($patternWUmlauts)/ or /^(\S)/;

4970

4971

# everything should be handled - this code should never be executed!

4972

die qq([BUG] $sourceFile, line $lineNrs{$inHandle}: No symbol found in "$_"!\n);

4973

}

4974

}

4975

4976

4977

# evaluate a tag condition (can possibly be generalized: this is just a piece of code)

4978

sub _evalTagCondition

4979

{

4980

# get parameters

4981

my ($code, $file, $line)=@_;

4982

confess "[BUG] Missing code parameter.\n" unless defined $code;

4983

confess "[BUG] Missing file parameter.\n" unless defined $file;

4984

confess "[BUG] Missing line parameter.\n" unless defined $line;

4985

4986

# declare variables

4987

my ($rc);

4988

4989

# Does the caller want to evaluate the code?

4990

if ($safeObject)

4991

{

4992

# update active contents base data, if necessary

4993

488

if ($flags{activeBaseData})

208487

4994

{

4995

no strict 'refs';

4996

${join('::', ref($safeObject) ? $safeObject->root : 'main', 'PerlPoint')}=dclone($flags{activeBaseData});

4997

}

4998

4999

# make the code a string and evaluate it

5000

warn "[Trace] $sourceFile, line $line: Evaluating this code:\n\n$code\n\n\n" if $flags{trace} & TRACE_ACTIVE;

5001

5002

# invoke perl to compute the result

5003

$rc=ref($safeObject) ? $safeObject->reval($code) : eval(join(' ', '{package main; no strict;', $code, '}'));

5004

5005

# check result

5006

_semerr($_[0], "$file, line $line: tag condition could not be evaluated: $@.") if $@;

5007

}

5008

5009

# supply result

5010

$rc;

5011

}

5012

5013

# reference lexed: reply appropriate token

5014

sub _refLexed

5015

{

5016

# get parameters

5017

my ($parser)=@_;

5018

100

5019

# we got an already prepared stream part or a delayed token

5020

if (ref($parser->{USER}->{INPUT}) eq 'PerlPoint::Parser::DelayedToken')

5021

{

5022

my $delayedToken=$parser->{USER}->{INPUT};

5023

$parser->{USER}->{INPUT}='';

5024

return($delayedToken->token, $delayedToken->value);

5025

}

5026

else

5027

{

5028

my $streamedPart=$parser->{USER}->{INPUT};

5029

$parser->{USER}->{INPUT}='';

5030

return('StreamedPart', [$streamedPart, $lineNrs{$inHandle}]);

5031

}

5032

}

5033

5034

5035

sub _lineStartResearch

5036

1056

1761

{

5037

# get parameters

5038

my ($parser)=@_;

5039

1056

100

15162

5040

# scan for indented lines, if necessary

5041

323

100

1516

if ($parser->{USER}->{INPUT}=~/^(\s+)/)

100

5042

{

5043

if ($lexerFlags{ils}==LEXER_TOKEN)

5044

104

{

5045

# trace, if necessary

5046

warn "[Trace] Lexer: Ils in line $lineNrs{$inHandle}.\n" if $flags{trace} & TRACE_LEXER;

5047

5048

512

# update input buffer and reply the token (contents is necessary as well)

5049

189

my $ils=$1;

5050

$parser->{USER}->{INPUT}=~s/^$1//;

5051

return(1, 'Ils', [$ils, $lineNrs{$inHandle}]);

5052

}

5053

663

elsif ($lexerFlags{ils}==LEXER_IGNORE)

5054

114

{

5055

warn "[Trace] Lexer: Ils in line $lineNrs{$inHandle} is ignored.\n" if $flags{trace} & TRACE_LEXER;

5056

$parser->{USER}->{INPUT}=~s/^(\s+)//;

5057

}

5058

}

5059

5060

# scan for a need of a virtual token opening a new paragraph

5061

# (to avoid parser state trouble caused by filters when the parser needs a lookahead

5062

1031

100

5120

# to detect the next paragraph)

5063

# warn "------> state $parserState (", STATE_DEFAULT, "), flag $flags{virtualParagraphStart}, $lexerFlagsOfPreviousState{cbell}\n";

5064

if ($parserState==STATE_DEFAULT and $flags{virtualParagraphStart} and $lexerFlagsOfPreviousState{cbell} ne LEXER_IGNORE)

5065

{

5066

warn "[Trace] Inserted virtual token to enable clean parser lookahead after pfilter invokation.\n" if $flags{trace} & TRACE_LEXER;

5067

return(1, 'Word', ['', $lineNrs{$inHandle}])

5068

if $lexerFlagsOfPreviousState{cbell} eq 'Ils'

5069

or $parser->{USER}->{INPUT}!~/^$lexerFlagsOfPreviousState{cbell}/;

5070

}

5071

1027

100

8067

100

5072

# scan for a new paragraph opened by a tag, if necessary

5073

if (($parserState==STATE_DEFAULT or $parserState==STATE_PFILTERED) and $parser->{USER}->{INPUT}=~/^\\/)

5074

165

{

5075

# remain in default state, but switch to its tag mode

5076

_stateManager(STATE_DEFAULT_TAGMODE);

5077

}

5078

1027

4098

5079

# flag that there is no token to return

5080

5081

}

5082

5083

# ----------------------------------------------------------------------------------------------

5084

# Internal function: error message display.

5085

# ----------------------------------------------------------------------------------------------

5086

sub _Error

5087

{

5088

# get parameters

5089

my ($parser)=@_;

5090

5091

# declare base indention

5092

my $baseIndentation=' ' x length('[Error] ');

5093

5094

124

# use $_[0]->YYCurtok to display the recognized *token* if necessary

5095

# - for users convenience, it is suppressed in the message

5096

warn "\n\n[Error] $sourceFile, ",

5097

${$parser->YYCurval}[1] > 0 ? "line ${$parser->YYCurval}[1]" : 'all sources read',

5098

(exists $statistics{cache} and $statistics{cache}[1]) ? ' (or below because of cache hits)'

5099

100

: (),

100

1201

5100

': found ',

5101

defined ${$parser->YYCurval}[0] ? qq("${$parser->YYCurval}[0]") : 'nothing',

5102

", expected:\n$baseIndentation",

5103

' ' x length('or '),

5104

join("\n${baseIndentation}or ",

5105

map {

5106

exists $tokenDescriptions{$_} ? defined $tokenDescriptions{$_} ? $tokenDescriptions{$_}

5107

: ()

5108

: $_

5109

} sort grep($_!~/cache_hit$/, $parser->YYExpect)

5110

5111

".\n\n";

5112

5113

520

# visualize error position

357

5114

warn(

5115

(map {my $l=$_->[1]; chomp($l); "$baseIndentation$l\n"} reverse @inLine==1 ? @inLine : @inLine[0, -1]), "",

5116

$baseIndentation, ' ' x ($inLine[0][0]-length($parser->{USER}->{INPUT})-1), "^\n",

5117

$baseIndentation, '_' x ($inLine[0][0]-length($parser->{USER}->{INPUT})-1), '|', "\n\n\n"

5118

) if @inLine;

5119

}

5120

5121

# ----------------------------------------------------------------------------------------------

5122

# Internal function: state manager.

5123

# ----------------------------------------------------------------------------------------------

5124

sub _stateManager

5125

1225

2313

{

5126

# get parameter

5127

my ($newState)=@_;

5128

1225

100

17946

100

5129

# check parameter

5130

confess "[BUG] Invalid new state $newState passed.\n" unless $newState==STATE_DEFAULT

5131

or $newState==STATE_DEFAULT_TAGMODE

5132

or $newState==STATE_TEXT

5133

or $newState==STATE_UPOINT

5134

or $newState==STATE_OPOINT

5135

or $newState==STATE_DPOINT

5136

or $newState==STATE_DPOINT_ITEM

5137

or $newState==STATE_BLOCK

5138

or $newState==STATE_VERBATIM

5139

or $newState==STATE_EMBEDDING

5140

or $newState==STATE_PFILTER

5141

or $newState==STATE_PFILTERED

5142

or $newState==STATE_CONDITION

5143

or $newState==STATE_HEADLINE_LEVEL

5144

or $newState==STATE_HEADLINE

5145

or $newState==STATE_TABLE

5146

or $newState==STATE_DEFINITION

5147

or $newState==STATE_CONTROL

5148

or $newState==STATE_COMMENT;

5149

1225

2210

5150

# store the new state

5151

$parserState=$newState;

5152

5153

1225

100

3164

# enter new state: default

5154

$newState==STATE_DEFAULT and do

5155

530

100

5577

{

5156

# buffer last states lexer flags (take care of a clean init)

5157

%lexerFlagsOfPreviousState=%lexerFlags ? %lexerFlags : (cbell => LEXER_IGNORE);

5158

530

2619

5159

# prepare lexer

5160

@lexerFlags{qw(ils eol el cbell)}=(LEXER_TOKEN, LEXER_EMPTYLINE, LEXER_IGNORE, LEXER_IGNORE);

5161

530

5008

5162

# activate special characters as necessary

5163

@specials{('.', '/', '*', '#', '=', '<', '>', '{', '}' , '-', '?', '@', '+', '~', 'heredoc', 'colon', 'tag', 'embedded', 'number', 'pfilter')}=(1, 1, 1, 1, 1, 1, 1, 0, 0, 1, 1, 1, 1, 1, 1, 1, 1, 0, 0, 1);

5164

530

2632

5165

# trace, if necessary

5166

warn "[Trace] Entered default state.\n" if $flags{trace} & TRACE_SEMANTIC;

5167

530

1463

5168

# well done

5169

return;

5170

};

5171

5172

695

100

1843

# enter new state: paragraph filter installation

5173

$newState==STATE_PFILTER and do

5174

{

5175

# prepare lexer

5176

@lexerFlags{qw(ils eol el cbell)}=(LEXER_TOKEN, LEXER_EMPTYLINE, LEXER_IGNORE, LEXER_IGNORE);

5177

5178

# activate special characters as necessary

5179

5180

5181

# trace, if necessary

5182

warn "[Trace] Entered pfilter installation state.\n" if $flags{trace} & TRACE_SEMANTIC;

5183

5184

# well done

5185

return;

5186

};

5187

5188

687

100

1795

# enter new state: paragraph filter (similar to default except for the name)

5189

$newState==STATE_PFILTERED and do

5190

{

5191

# prepare lexer

5192

@lexerFlags{qw(ils eol el cbell)}=(LEXER_TOKEN, LEXER_EMPTYLINE, LEXER_IGNORE, LEXER_IGNORE);

5193

5194

# activate special characters as necessary

5195

5196

5197

# trace, if necessary

5198

warn "[Trace] Entered postfilter default state.\n" if $flags{trace} & TRACE_SEMANTIC;

5199

5200

# well done

5201

return;

5202

};

5203

5204

5205

# enter new state: default in tag mode (same as default, but a paragraph starting with a tag delays switching to other

5206

679

100

1410

# modes, so we have to explicitly disable the paragraph opener specials)

5207

$newState==STATE_DEFAULT_TAGMODE and do

5208

219

{

5209

# prepare lexer

5210

@lexerFlags{qw(ils eol el cbell)}=(LEXER_TOKEN, LEXER_EMPTYLINE, LEXER_IGNORE, LEXER_IGNORE);

5211

518

5212

# activate special characters as necessary

5213

@specials{('.', '/', '*', '#', '=', '<', '>', '{', '}' , '-', '?', '@', '+', '~', 'heredoc', 'colon', 'tag', 'embedded', 'number', 'pfilter')}=(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0);

5214

277

5215

# trace, if necessary

5216

warn "[Trace] Entered default state in tag mode.\n" if $flags{trace} & TRACE_SEMANTIC;

5217

281

5218

# well done

5219

return;

5220

};

5221

5222

623

100

3149

# enter new state: headline body

5223

($newState==STATE_HEADLINE or $newState==STATE_HEADLINE_LEVEL) and do

5224

168

555

{

5225

# prepare lexer

5226

@lexerFlags{qw(ils eol el cbell)}=(LEXER_IGNORE, LEXER_SPACE, LEXER_TOKEN, LEXER_IGNORE);

5227

168

100

11048

5228

# activate special characters as necessary

5229

@specials{('.', '/', '*', '#', '=', '<', '>', '{', '}' , '-', '?', '@', '+', '~', 'heredoc', 'colon', 'tag', 'embedded', 'number', 'pfilter')}=(0, 0, 0, 0, $newState==STATE_HEADLINE ? 0 : 1, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 0);

5230

168

789

5231

# trace, if necessary

5232

warn "[Trace] Entered headline ", $newState==STATE_HEADLINE ? 'body' : 'level', " state.\n" if $flags{trace} & TRACE_SEMANTIC;

5233

168

320

5234

# well done

5235

return;

5236

};

5237

5238

455

100

1237

# enter new state: comment

5239

$newState==STATE_COMMENT and do

5240

{

5241

# prepare lexer

5242

@lexerFlags{qw(ils eol el cbell)}=(LEXER_IGNORE, LEXER_EMPTYLINE, LEXER_IGNORE, LEXER_IGNORE);

5243

5244

# activate special characters as necessary

5245

5246

5247

# trace, if necessary

5248

warn "[Trace] Entered comment state.\n" if $flags{trace} & TRACE_SEMANTIC;

5249

5250

# well done

5251

return;

5252

};

5253

5254

445

100

1153

# enter new state: text

5255

$newState==STATE_TEXT and do

5256

316

1190

{

5257

# prepare lexer

5258

@lexerFlags{qw(ils eol el cbell)}=(LEXER_IGNORE, LEXER_SPACE, LEXER_TOKEN, LEXER_IGNORE);

5259

316

1963

5260

# activate special characters as necessary

5261

5262

316

1111

5263

# trace, if necessary

5264

warn "[Trace] Entered text state.\n" if $flags{trace} & TRACE_SEMANTIC;

5265

316

920

5266

# well done

5267

return;

5268

};

5269

5270

129

100

450

# enter new state: text

5271

$newState==STATE_TABLE and do

5272

{

5273

# prepare lexer

5274

@lexerFlags{qw(ils eol el cbell)}=(LEXER_SPACE, LEXER_TOKEN, LEXER_TOKEN, LEXER_IGNORE);

5275

5817

5276

# activate special characters as necessary

5277

5278

630

5279

# trace, if necessary

5280

warn "[Trace] Entered table paragraph state.\n" if $flags{trace} & TRACE_SEMANTIC;

5281

5282

# well done

5283

return;

5284

};

5285

5286

122

100

451

# enter new state: text

5287

$newState==STATE_DEFINITION and do

5288

{

5289

# prepare lexer

5290

@lexerFlags{qw(ils eol el cbell)}=(LEXER_IGNORE, LEXER_SPACE, LEXER_TOKEN, LEXER_IGNORE);

5291

5292

# activate special characters as necessary

5293

@specials{('.', '/', '*', '#', '=', '<', '>', '{', '}' , '-', '?', '@', '+', '~', 'heredoc', 'colon', 'tag', 'embedded', 'number', 'pfilter')}=(0, 0, 0, 0, 1, 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0);

5294

5295

# trace, if necessary

5296

warn "[Trace] Entered macro definition state.\n" if $flags{trace} & TRACE_SEMANTIC;

5297

5298

# well done

5299

return;

5300

};

5301

5302

115

100

288

# enter new state: unordered list point - defined item

5303

($newState==STATE_DPOINT_ITEM) and do

5304

{

5305

# prepare lexer

5306

@lexerFlags{qw(ils eol el cbell)}=(LEXER_IGNORE, LEXER_SPACE, LEXER_TOKEN, LEXER_TOKEN);

5307

5308

# activate special characters as necessary

5309

5310

5311

# trace, if necessary

5312

warn "[Trace] Entered definition item state.\n" if $flags{trace} & TRACE_SEMANTIC;

5313

5314

# well done

5315

return;

5316

};

5317

5318

109

100

1016

# enter new state: list point

100

5319

($newState==STATE_UPOINT or $newState==STATE_OPOINT or $newState==STATE_DPOINT) and do

5320

176

{

5321

# prepare lexer

5322

@lexerFlags{qw(ils eol el cbell)}=(LEXER_IGNORE, LEXER_SPACE, LEXER_TOKEN, qr([*#:]));

5323

298

5324

# activate special characters as necessary

5325

5326

159

5327

# trace, if necessary

5328

warn "[Trace] Entered point state.\n" if $flags{trace} & TRACE_SEMANTIC;

5329

5330

# well done

5331

return;

5332

};

5333

5334

100

243

# enter new state: block

5335

$newState==STATE_BLOCK and do

5336

123

{

5337

# prepare lexer

5338

@lexerFlags{qw(ils eol el cbell)}=(LEXER_SPACE, LEXER_TOKEN, LEXER_TOKEN, 'Ils');

5339

254

5340

# activate special characters as necessary

5341

5342

124

5343

# trace, if necessary

5344

warn "[Trace] Entered block state.\n" if $flags{trace} & TRACE_SEMANTIC;

5345

5346

# well done

5347

return;

5348

};

5349

5350

100

165

# enter new state: verbatim block

5351

$newState==STATE_VERBATIM and do

5352

{

5353

# prepare lexer

5354

@lexerFlags{qw(ils eol el cbell)}=(LEXER_SPACE, LEXER_TOKEN, LEXER_TOKEN, LEXER_IGNORE);

5355

5356

# activate special characters as necessary

5357

5358

5359

# trace, if necessary

5360

warn "[Trace] Entered verbatim state.\n" if $flags{trace} & TRACE_SEMANTIC;

5361

5362

# well done

5363

return;

5364

};

5365

5366

100

136

# enter new state: embedding

5367

$newState==STATE_EMBEDDING and do

5368

{

5369

# prepare lexer

5370

@lexerFlags{qw(ils eol el cbell)}=(LEXER_SPACE, LEXER_TOKEN, LEXER_TOKEN, LEXER_IGNORE);

5371

163

5372

# activate special characters as necessary

5373

5374

138

5375

# trace, if necessary

5376

warn "[Trace] Entered embedding state.\n" if $flags{trace} & TRACE_SEMANTIC;

5377

5378

# well done

5379

return;

5380

};

5381

5382

100

# enter new state: condition (very similar to embedding, naturally)

5383

$newState==STATE_CONDITION and do

5384

{

5385

# prepare lexer

5386

@lexerFlags{qw(ils eol el cbell)}=(LEXER_SPACE, LEXER_SPACE, LEXER_TOKEN, LEXER_IGNORE);

5387

5388

# activate special characters as necessary

5389

5390

5391

# trace, if necessary

5392

warn "[Trace] Entered condition state.\n" if $flags{trace} & TRACE_SEMANTIC;

5393

5394

# well done

5395

return;

5396

};

5397

5398

# enter new state: unordered list point

5399

$newState==STATE_CONTROL and do

5400

{

5401

# prepare lexer

5402

@lexerFlags{qw(ils eol el cbell)}=(LEXER_IGNORE, LEXER_IGNORE, LEXER_TOKEN, LEXER_IGNORE);

5403

5404

# activate special characters as necessary

5405

5406

5407

# trace, if necessary

5408

warn "[Trace] Entered control state.\n" if $flags{trace} & TRACE_SEMANTIC;

5409

5410

# well done

5411

return;

5412

};

5413

5414

# check yourself

5415

confess "[BUG] Unhandled state $newState.\n";

5416

}

5417

5418

5419

=pod

5420

5421

=head2 run()

5422

5423

This function starts the parser to process a number of specified files.

5424

5425

5426

All parameters except of the I

5427

5428

=over 4

5429

5430

=item activeBaseData

5431

5432

This optional parameter allows to pass common data to all active contents

5433

(conditions, embedded and included Perl) by a I. By convention,

5434

a translator at least passes the target language and user settings by

5435

5436

activeBaseData => {

5437

targetLanguage => "lang",

5438

userSettings => \%userSettings,

5439

5440

5441

User settings are intended to allow the specification of per call settings by a

5442

user, e.g. to include special parts. By using this convention, users can easily

5443

specify such a part the following way

5444

5445

? flagSet('setting')

5446

5447

Special part.

5448

5449

? 1

5450

5451

It is up to a translator author to declare translator specific settings (and to

5452

document them). The passed values can be as complex as necessary as long as they

5453

can be duplicated by C.

5454

5455

Whenever active contents is invoked, the passed hash reference is copied

5456

(duplicated by C) into the Safe objects namespace

5457

(see I) as a global variable $PerlPoint. This way, modifications by

5458

invoked code do not effect subsequently called code snippets, base data are

5459

always fresh.

5460

5461

=item activeDataInit

5462

5463

Reserved to pass hook functions to be called preparing every active contents

5464

invokation. I

5465

5466

=item cache

5467

5468

This optional parameter controls source file paragraph caching.

5469

5470

By default, a source file is parsed completely everytime you pass it to the

5471

parser. This is no problem with tiny sources but can delay your work if you

5472

are dealing with large sources which have to be translated periodically into

5473

presentations while they are written. Typically most of the paragraphs remain

5474

unchanged from version to version, but nevertheless everything is usually

5475

reparsed which means a waste of time. Well, to improve this a paragraph

5476

cache can be activated by setting this option to B.

5477

5478

The parser caches each I individually. That means

5479

if three files are passed to the parser with activated caching, three cache

5480

files will be written. They are placed in the source file directory, named

5481

..ppcache. Please note that the paragraphs of I sources

5482

are cached in the cache file of the I

document because they may have to

5483

be evaluated differently depending on inclusion context.

5484

5485

What acceleration can be expected? Well, this I

5486

depends on your source structure. Efficiency will grow with longer paragraphs,

5487

reused paragraphs and paragraph number. It will be reduced by heavy usage

5488

of active contents and embedding because every paragraph that refers

5489

to parts defined externally is not strongly determined by itself and therefore

5490

it cannot be cached. Here is a list of all reasons which cause a paragraph to

5491

be excluded from caching:

5492

5493

=over 4

5494

5495

=item Embedded parts

5496

5497

Obviously dynamic parts may change from one version to another, but even static

5498

parts could have to be interpreted differently because a user can set up new

5499

Is.

5500

5501

=item Included files

5502

5503

An \INCLUDE tag immediately disables caching for the paragraph it resides in

5504

because the loaded file may change its contents. This is not really a

5505

restriction because the included paragraphs themselves I cached if possible.

5506

5507

=item Filtered paragraphs

5508

5509

A paragraph filter can transform a source paragraph in whatever the author of

5510

a Perl function might think is useful, potentially depending on highly dynamical

5511

data. So it cannot be determined by the parser what the final translation of a

5512

certain source paragraph will be.

5513

5514

=item Document stream entry points

5515

5516

Depending on the parsers configuration, these points can be transformed into

5517

headlines or remain unchanged, so there is no fixed up mapping between a

5518

source paragraph and its streamed expression.

5519

5520

=back

5521

5522

Even with these restrictions about 70% of a real life document of more than

5523

150 paragraphs could be cached. This saved more than 60% of parsing time in

5524

subsequent translator calls.

5525

5526

New cache entries are always I which means that old entries are never

5527

replaced and a cache file tends to grow. If you ever wish to clean up a

5528

cache file completely pass B to this option.

5529

5530

To deactivate caching explicitly pass B.

5531

5532

5533

Settings can be combined by I.

5534

5535

# clean up the cache, then refill it

5536

cache => CACHE_CLEANUP+CACHE_ON,

5537

5538

# clean up the cache and deactivate it

5539

cache => CACHE_CLEANUP+CACHE_OFF,

5540

5541

The B value is overwritten by any other setting.

5542

5543

It is suggested to make this setting available to translator users to let

5544

them decide if a cache should be used.

5545

5546

I that there is a problem with line numbers if paragraphs are

5547

restored from cache because of the behaviour of perls paragraph mode. In this

5548

mode, the <> operator reads in any number of newlines between paragraphs but

5549

supplies only one of them. That is why I do not get the real number of lines

5550

in a paragraph and therefore cannot store them. To work around this, two

5551

strategies can be used. First, do not use more than exactly one newline

5552

between paragraphs. (This strategy is not for real life users, of course,

5553

but in this case restored numbers would be correct.) Second, remember that

5554

source line numbers are only interesting in error messages. If the parser

5555

detects an error, it therefore says: error "there or later" when a cache hit

5556

already occured. If the real number is wished the parser could be reinvoked

5557

then with deactivated cache and will report it.

5558

5559

I occurs if you parse on a UNIX

5560

system but your document (or parts of it) were written in DOS format. The

5561

paragraph mode reads such a document I. Please replace the line

5562

ending character sequences system appropriate. (If you are using C

5563

under Solaris please invoke it with option C<-ascii> to do this.)

5564

5565

More, Perls paragraph mode and PerlPoint treat whitespace lines differently.

5566

Because of the way it works, paragraph mode does not recognize them as "empty"

5567

while PerlPoint I for reasons of usability (invisible characters should

5568

not make a difference). This means that lines containing only whitespaces

5569

separate PerlPoint paragraphs but not "Perl" paragraphs, making the cache

5570

working wrong especially in examples. If paragraphs unintentionally disappear

5571

in the resulting presentation, please check the "empty lines" before them.

5572

5573

Consistent cache data depend on the versions of the parser, of constant

5574

declarations and of the module B which is used internally. If the

5575

parser detects a significant change in one of these versions, existing

5576

caches are automatically rebuilt.

5577

5578

I cache files are not locked while they are used.

5579

If you need this feature please let me know.

5580

5581

=item criticalSemanticErrors

5582

5583

If set to a true value, semantic errors will cause the parser to terminate

5584

immediately. This defaults to false: errors are accumulated and finally

5585

reported.

5586

5587

=item display

5588

5589

This parameter is optional. It controls the display of runtime messages

5590

like informations or warnings. By default, all messages are displayed. You

5591

can suppress these informations partially or completely by passing one or

5592

more of the "DISPLAY_..." variables declared in B.

5593

Constants should be combined by addition.

5594

5595

=item docstreams2skip

5596

5597

by default, all document streams are made part of the result, but by this

5598

parameter one can I certain streams (all remaining ones will be

5599

streamed as usual).

5600

5601

The list should be supplied by an array reference.

5602

5603

It is suggested to take the values of this parameter from a user option,

5604

which by convention should be named C<-skipstream>.

5605

5606

=item docstreaming

5607

5608

specifies the way the parser handles stream entry points. The value passed

5609

might be either C, C or C.

5610

5611

C instructs the parser to transform the entry points

5612

into I, one level below the current real headline level. This

5613

is an easy to implement and convenient way of docstream handling seems to

5614

make sense in most target formats.

5615

5616

C hides all streams except of the main stream. The effect

5617

is similar to a call with I set for all document streams

5618

in a source.

5619

5620

C treats the entry points as entry points and streams

5621

them as such. This is the default if the parameter is omitted.

5622

5623

Please note that filters applied by I work regardless of

5624

the I configuration which only affects the way the parser

5625

passes docstream data to a backend.

5626

5627

It is recommended to take the value of this parameter from a user option,

5628

which by convention should be named C<-docstreaming>. (A converter can

5629

define various more modes than provided by the parser and implement them

5630

itself, of course. See C for a reference implementation.)

5631

5632

5633

=item files

5634

5635

a reference to an array of files to be scanned.

5636

5637

Files are treated as PerlPoint sources except when their name has the

5638

prefix C, as in C. With this prefix, the

5639

parser tries to automatically tranform the source into PerlPoint,

5640

using a standard import filter for the format indicated by the file

5641

extension (C in our example). The filter must be installed as

5642

Cuppercased format nameE>, e.g.

5643

5644

5645

=item filter

5646

5647

a regular expression describing the target language. This setting, if used,

5648

prevents all embedded or included source code of other languages than the set

5649

one from inclusion into the generated stream. This accelerates both parsing

5650

and backend handling. The pattern is evaluated case insensitively.

5651

5652

Example: pass "html|perl" to allow HTML and Perl.

5653

5654

To illustrate this, imagine a translator to PostScript. If it reads a Perl

5655

Point file which includes native HTML, this translator cannot handle such code.

5656

The backend would have to skip the HTML statements. With a "PostScript" filter,

5657

the HTML code will not appear in the stream.

5658

5659

This enables PerlPoint texts prepared for various target languages. If an

5660

author really needs plain target language code to be embedded into PerlPoint,

5661

he could provide versions for various languages. Translators using a filter

5662

will then receive exactly the code of their target language, if provided.

5663

5664

Please note that you cannot filter out PerlPoint code or example files.

5665

5666

By default, no filter is set.

5667

5668

5669

=item headlineLinks

5670

5671

this optional flag causes the parser to register all headline

5672

titles as anchors automatically. (Headlines are stored without

5673

possibly included tags which are stripped off.)

5674

5675

Registering anchors does \I mean there are anchors included

5676

to the stream, it just means that they are known to exist at

5677

parsing time because they are added to an internal C

5678

object which is passed to all tag hooks and can be evaluated there.

5679

See \C and C for details.

5680

5681

It is recommended to make use of this feature if your converter

5682

automatically makes headlines an anchor named like the headline

5683

(this feature was introduced by Lorenz Domkes C initially).

5684

(Nevertheless, usefulness may depend on dealing with the parsers

5685

anchor collection in tag hooks. See the documentations of used

5686

tag modules for details.)

5687

5688

If your converter does not support automatic headline anchors

5689

the mentioned way, it is recommended to omit this option because

5690

it could confuse tag hooks that evaluate the parsers anchor collection.

5691

5692

5693

=item libpath

5694

5695

An optional reference to an array of library pathes to be searched for

5696

files specified by \INCLUDE tags. This array is intended to be filled

5697

by directories specified via an converter option. By convention, this

5698

option is named C and should be enabled multiple times

5699

(C).

5700

5701

Please note that library pathes can be set via environment variable

5702

C as well, but directories specified via C are

5703

searched I.

5704

5705

5706

=item linehints

5707

5708

If set to a true value, the parser will embed line hints into the stream

5709

whenever a new source line begins.

5710

5711

A line hint directive is provided as

5712

5713

[

5714

DIRECTIVE_NEW_LINE, DIRECTIVE_START,

5715

{file=>filename, line=>number}

5716

]

5717

5718

and is suggested to be handled by a backend callback.

5719

5720

Please note that currently source line numbers are not guaranteed to be

5721

correct if stream parts are restored from I (see there for details).

5722

5723

The default value is 0.

5724

5725

=item nestedTables

5726

5727

This is an optional flag which is by default set to 0, indicating if the parser

5728

shall accept nested tables or not. Table nesting can produce very nice results

5729

if it is supported by the target language. HTML, for example, allows to nest

5730

tables, but other languages I. So, using this feature can really improve

5731

the results if a user is focussed on supporting certain target formats only. If I want

5732

to produce nothing but HTML, why should I take care of target formats not able

5733

to handle table nesting? On the other hand, I a document shall be translated

5734

into several formats, it might cause trouble to nest tables therein.

5735

5736

Because of this, it is suggested to let converter users decide if they want to

5737

enable table nesting or not. If the target format does not support nesting, I

5738

recommend to disable nesting completely.

5739

5740

5741

=item object

5742

5743

the parser object made by I;

5744

5745

=item safe

5746

5747

an object of the B class which comes with perl. It is used to evaluate

5748

embedded Perl code in a safe environment. By letting the caller of I

5749

provide this object, a translator author can make the level of safety fully

5750

configurable by users. Usually, the following should work

5751

5752

use Safe;

5753

...

5754

$parser->run(safe=>new Safe, ...);

5755

5756

Safe is a really good module but unfortunately limited in loading modules

5757

transparently. So if a user wants to use modules in his embedded code, he

5758

might fail to get it working in a Safe compartment. If safety does not matter,

5759

he can decide to execute it without Safe, with full Perl access. To switch

5760

on this mode, pass a true scalar value (but no reference) instead of a Safe

5761

object.

5762

5763

To make all PerlPoint converters behave similarly, it is recommended to provide

5764

two related options C<-activeContents> and C<-safeOpcode>. C<-activeContents>

5765

should flag that active contents shall be evaluated, while C<-safeOpcode>

5766

controls the level of security. A special level C should mean that all

5767

code can b executed without any restriction, while any other settings should be

5768

treated as an opcode to configure the Safe object. So, the recommended rules

5769

are: pass 0 unless C<-activeContents> is set. Pass 1 if the converter was

5770

called with C<-activeContents> I C<-safeOpcode ALL>. Pass a Safe object

5771

and configure it according to the users C<-safeOpcode> settings if

5772

C<-activeContents> is used but without C<-safeOpcode ALL>. See C

5773

for an implementation example.

5774

5775

Active Perl contents is I if this setting is omitted or if anything

5776

else than a B object is passed. (There are currently three types of active

5777

contents: embedded or included Perl and condition paragraphs.)

5778

5779

5780

=item predeclaredVars

5781

5782

Variables are usually set by assignment paragraphs. However, it may be useful

5783

for a converter to predeclare a set of them to provide certain settings to the

5784

users. Predeclared variables, as any other PerlPoint variables, can be used

5785

both in pure PerlPoint and in active contents. To help users distinguish them

5786

from user defined vars, their names will be I.

5787

5788

Just pass a hash of variable name / value pairs:

5789

5790

$parser->run(

5791

...

5792

predeclaredVars => {

5793

CONVERTER_NAME => 'pp2xy',

5794

CONVERTER_VERSION => $VERSION,

5795

...

5796

5797

);

5798

5799

Non capitalized variable names will be capitalized without further notice.

5800

5801

Please note that variables currently can only be scalars. Different data types

5802

will not be accepted by the parser.

5803

5804

Predeclared variables should be mentioned in the converters documentation.

5805

5806

The parser itself makes use of this feature by declaring C<_PARSER_VERSION>

5807

(the version of this module used to parse the source) and _STARTDIR (the full

5808

path of the startup directory, as reported by C).

5809

5810

C needs C to take effect.

5811

5812

5813

=item skipcomments

5814

5815

By default comments are streamed and can be converted into comments of the target language.

5816

But often they are of limited use in generated files: especially if they are intended to

5817

help the author of a document, not the reader of the source of generated results. So with

5818

this option one can suppress comments from being streamed.

5819

5820

It is suggested to get this setting via user option,

5821

which by convention should be named C<-skipcomments>.

5822

5823

=item stream

5824

5825

A reference to an array where the generated output stream should be stored in.

5826

5827

Application programmers may want to tie this array if the target ASCII

5828

texts are expected to be large (long ASCII texts can result in large stream

5829

data which may occupy a lot of memory). Because of the fact that the parser

5830

stores stream data I, memory consumption can be reduced

5831

significantly by tying the stream array.

5832

5833

It is recommended to pass an empty array. Stored data will not be overwritten,

5834

the parser I its data instead (by C).

5835

5836

=item trace

5837

5838

This parameter is optional. It is intended to activate trace code while the method

5839

runs. You may pass any of the "TRACE_..." constants declared in B,

5840

combined by addition as in the following example:

5841

5842

# show the traces of both

5843

# lexical and syntactical analysis

5844

trace => TRACE_LEXER+TRACE_PARSER,

5845

5846

If you omit this parameter or pass TRACE_NOTHING, no traces will be displayed.

5847

5848

=item var2stream

5849

5850

If set to a true value, the parser will propagate variable settings into the stream

5851

by adding additional C directives.

5852

5853

A variable propagation has the form

5854

5855

[

5856

DIRECTIVE_VARSET, DIRECTIVE_START,

5857

{var=>varname, value=>value}

5858

]

5859

5860

and is suggested to be handled by a backend callback.

5861

5862

The default value is 0.

5863

5864

=item vispro

5865

5866

activates "process visualization" which simply means that a user will see

5867

progress messages while the parser processes documents. The I

5868

value of this setting determines how often the progress message shall be

5869

updated, by a I:

5870

5871

# inform every five chapters

5872

vispro => 5,

5873

5874

Process visualization is automatically suppressed unless STDERR is

5875

connected to a terminal, if this option is omitted, I was set

5876

to C or parser Is are activated.

5877

5878

=back

5879

5880

5881

A "true" value in case of success, "false" otherwise. A call is performed

5882

successfully if there was neither a syntactical nor a semantic error in the

5883

parsed files.

5884

5885

5886

5887

$parser->run(

5888

stream => \@streamData,

5889

files => \@ARGV,

5890

filter => 'HTML',

5891

cache => CACHE_ON,

5892

trace => TRACE_PARAGRAPHS,

5893

);

5894

5895

=cut

5896

sub run

5897

147709

{

5898

# get parameters

5899

my ($me, @pars)=@_;

5900

215

5901

312

# build parameter hash

5902

confess "[BUG] The number of parameters should be even.\n" if @pars%2;

5903

my %pars=@pars;

5904

370

5905

391

# and check parameters

5906

187

confess "[BUG] Missing object parameter.\n" unless $me;

5907

353

confess "[BUG] Object parameter is no ", __PACKAGE__, " object.\n" unless ref $me and ref $me eq __PACKAGE__;

5908

170

confess "[BUG] Missing stream array reference parameter.\n" unless $pars{stream};

5909

384

confess "[BUG] Stream array reference parameter is no array reference.\n" unless ref $pars{stream} and ref $pars{stream} eq 'ARRAY';

5910

confess "[BUG] Missing file list reference parameter.\n" unless $pars{files};

188

5911

334

confess "[BUG] File list reference parameter is no array reference.\n" unless ref $pars{files} and ref $pars{files} eq 'ARRAY';

5912

217

confess "[BUG] You should pass at least one file to parse.\n" unless @{$pars{files}};

5913

247

confess "[BUG] Active base data reference is no hash reference.\n" if exists $pars{activeBaseData} and ref $pars{activeBaseData} ne 'HASH';

5914

100

183

confess "[BUG] Active data initializer is no code reference.\n" if exists $pars{activeDataInit} and ref $pars{activeDataInit} ne 'CODE';

5915

confess "[BUG] Document stream skip list is no array reference.\n" if exists $pars{docstreams2skip} and ref $pars{docstreams2skip} ne 'ARRAY';

5916

1094

if (exists $pars{filter})

5917

{

5918

eval "'lang'=~/$pars{filter}/";

5919

confess qq([BUG] Invalid filter expression "$pars{filter}": $@.\n) if $@;

5920

}

5921

124

5922

# variables

5923

my ($rc, %docHints)=(1);

5924

5925

# init internal data

5926

(

5927

$resultStreamRef, # 1

5928

$safeObject, # 2

5929

$flags{trace}, # 3

5930

$flags{display}, # 4

5931

$flags{filter}, # 5

5932

$flags{linehints}, # 6

5933

$flags{var2stream}, # 7

5934

$flags{cache}, # 8

5935

$flags{cached}, # 9

5936

$flags{vis}, # 10

5937

$flags{activeBaseData}, # 11

5938

$flags{activeDataInit}, # 12

5939

$flags{nestedTables}, # 13

5940

$flags{headlineLinks}, # 14

5941

$flags{skipcomments}, # 15

5942

$flags{docstreams2skip}, # 16

5943

$flags{docstreaming}, # 17

5944

$flags{criticalSemantics}, # 18

5945

$macroChecksum, # 19

5946

$varChecksum, # 20

5947

$anchors, # 21

5948

)=(

5949

$pars{stream}, # 1

5950

( # 2

5951

exists $pars{safe}

5952

and defined $pars{safe}

5953

) ? ref($pars{safe}) eq 'Safe' ? $pars{safe}

5954

: 1

5955

: 0,

5956

exists $pars{trace} ? $pars{trace} : TRACE_NOTHING, # 3

5957

exists $pars{display} ? $pars{display} : DISPLAY_ALL, # 4

5958

exists $pars{filter} ? $pars{filter} : '', # 5

5959

(exists $pars{linehints} and $pars{linehints}), # 6

5960

(exists $pars{var2stream} and $pars{var2stream}), # 7

5961

exists $pars{cache} ? $pars{cache} : CACHE_OFF, # 8

5962

0, # 9

5963

exists $pars{vispro} ? $pars{vispro} : 0, # 10

5964

exists $pars{activeBaseData} ? $pars{activeBaseData} : 0, # 11

5965

exists $pars{activeDataInit} ? $pars{activeDataInit} : 0, # 12

5966

exists $pars{nestedTables} ? $pars{nestedTables} : 0, # 13

5967

100

1956

exists $pars{headlineLinks} ? $pars{headlineLinks} : 0, # 14

100

5968

(exists $pars{skipcomments} and $pars{skipcomments}), # 15

5969

exists $pars{docstreams2skip} ? {map {($_ => undef)} @{$pars{docstreams2skip}}} : 0, # 16

5970

exists $pars{docstreaming} ? $pars{docstreaming} : DSTREAM_DEFAULT, # 17

5971

exists $pars{criticalSemanticErrors} ? $pars{criticalSemanticErrors} : 0, # 18

5972

0, # 19

5973

0, # 20

5974

PerlPoint::Anchors->new, # 21

5975

);

5976

100

367

5977

# prepare stream data structure and appropriate handlers

5978

unless (@$resultStreamRef and $resultStreamRef->[STREAM_IDENT] eq '__PerlPoint_stream__')

5979

513

{

5980

# empty stream

5981

128

@$resultStreamRef=();

801

5982

# initiate

5983

@{$resultStreamRef}[

5984

STREAM_IDENT,

5985

STREAM_TOKENS,

5986

STREAM_HEADLINES,

5987

]=(

5988

'__PerlPoint_stream__', # stream identifier;

5989

[], # base stream;

5990

[], # headline stream;

5991

);

5992

}

5993

100

324

5994

# declare helper subroutines to be used in active contents

5995

if ($safeObject)

5996

{

5997

my $code=<<'EOC';

5998

5999

unless (defined *main::flagSet{CODE})

6000

{

6001

# check if at least one of a set of flags is set

6002

# - define functions anonymously to avoid redefinition in case the condition is not matched

6003

*main::flagSet=sub

6004

{

6005

# declare and init variable

6006

my $rc=0;

6007

6008

# check flags

6009

foreach (@_)

6010

{$rc=1, last if exists $PerlPoint->{userSettings}{$_};}

6011

6012

# supply result

6013

$rc;

6014

};

6015

6016

# provide the value of a PerlPoint variable

6017

# - define function anonymously to avoid redefinition in case the condition is not matched

6018

*main::varValue=sub {${join('::', 'main', $_[0])};};

6019

}

6020

6021

# complete compartment code

6022

100

393

EOC

585

6023

9590

6024

ref($safeObject) ? $safeObject->reval($code) : eval("{package main; no strict; $code}");

6025

die "[BUG] Bug in function definition, please inform developer: $@" if $@;

6026

}

6027

294864

6028

# predeclare variables

6029

_predeclareVariables({_PARSER_VERSION=>$PerlPoint::Parser::VERSION, _STARTDIR=>cwd()});

6030

100

1117

6031

# store initial variables, if necessary

6032

if (exists $pars{predeclaredVars})

6033

{

6034

# check data format

6035

confess "[BUG] Please pass predeclared variables by a hash reference .\n" unless ref($pars{predeclaredVars}) eq 'HASH';

6036

6037

# declare

6038

_predeclareVariables($pars{predeclaredVars});

6039

}

6040

576

6041

# update visualization flag

6042

$flags{vis}=0 unless $flags{vis}

6043

and not $flags{display} & &DISPLAY_NOINFO

6044

and not $flags{trace}>TRACE_NOTHING

6045

and -t STDERR;

6046

1003

6047

165

# init more

6048

100

608

@flags{qw(skipInput headlineLevelOffset headlineLevel olist virtualParagraphStart)}=(0) x 5;

6049

delete $flags{ifilters};

6050

$statistics{cache}[1]=0 if $flags{cache} & CACHE_ON;

6051

3496

6052

# init even more

6053

%paragraphTypeStrings=(

6054

DIRECTIVE_HEADLINE() => 'headline',

6055

DIRECTIVE_TEXT() => 'text',

6056

DIRECTIVE_UPOINT() => 'unordered list point',

6057

DIRECTIVE_ULIST() => 'list',

6058

DIRECTIVE_OPOINT() => 'ordered list point',

6059

DIRECTIVE_OLIST() => 'list',

6060

DIRECTIVE_DPOINT() => 'definition list point',

6061

DIRECTIVE_DLIST() => 'list',

6062

DIRECTIVE_BLOCK() => 'block',

6063

DIRECTIVE_VERBATIM() => 'verbatim block',

6064

DIRECTIVE_TAG() => 'tag',

6065

DIRECTIVE_LIST_RSHIFT() => 'right list shifter',

6066

DIRECTIVE_LIST_LSHIFT() => 'left list shifter',

6067

DIRECTIVE_COMMENT() => 'comment',

6068

100

292

);

6069

# check tag declarations

6070

unless (ref($PerlPoint::Tags::tagdefs) eq 'HASH')

6071

303

{

6072

# warn user

6073

warn "[Warn] No tags are declared. No tags will be detected.\n" unless $flags{display} & DISPLAY_NOWARN;

6074

209

6075

# init shortcut pointer

6076

$tagsRef={};

6077

}

6078

else

6079

{

6080

# ok, there are tags, make a shortcut

6081

$tagsRef=$PerlPoint::Tags::tagdefs;

6082

}

6083

6084

724

# build an array of include pathes - specified via environment variable PERLPOINTLIB

6085

# and parameter "libpath"

6086

100

552

confess "[BUG] Please pass library pathes by an array reference .\n" if exists $pars{libpath} and not ref($pars{libpath}) eq 'ARRAY';

100

6087

push(@libraryPath,

6088

exists $pars{libpath} ? @{$pars{libpath}} : (),

6089

exists $ENV{PERLPOINTLIB} ? split(/\s*;\s*/, $ENV{PERLPOINTLIB}) : (),

6090

);

6091

369

6092

# welcome user

6093

unless ($flags{display} & DISPLAY_NOINFO)

6094

{

6095

394

print STDERR "[Info] The PerlPoint parser ";

103

206143

6096

{

6097

no strict 'refs';

6098

print STDERR ${join('::', __PACKAGE__, 'VERSION')};

6099

}

6100

warn " starts.\n";

6101

warn " Active contents is ", $safeObject ? ref($safeObject) ? 'safely evaluated' : 'risky evaluated' : 'ignored', ".\n";

6102

6103

# report cache mode

6104

warn " Paragraph cache is ", ($flags{cache} & CACHE_ON) ? '' : 'de', "activated.\n";

6105

}

6106

302137

6107

# save current directory

6108

my $startupDirectory=cwd();

6109

1455

1209

6110

# scan all input files

6111

foreach my $file (@{$pars{files}})

6112

675

{

6113

# scopies

6114

my $specifiedFile=$file;

6115

994

6116

# scan for an import directive

6117

if ($file=~/^IMPORT:(.+)/)

6118

{

6119

# replace the original file by a temporary one ...

6120

my ($tmpHandle, $tmpFilename)=tempfile(UNLINK => ($flags{trace} & TRACE_TMPFILES ? 0 : 1));

6121

$file=$tmpFilename;

6122

6123

# which imports the real file

6124

my $realfile=abs_path($specifiedFile=$1);

6125

print $tmpHandle qq(\n\n\\INCLUDE{import=1 file="$realfile"}\n\n);

6126

close($tmpHandle);

6127

6128

# due to the extra level chances are we have to to accept a first paragraph that is not a headline

6129

$flags{complainedAbout1stHeadline}='IMPORT' unless exists $flags{complainedAbout1stHeadline} and $flags{complainedAbout1stHeadline} eq '1';

6130

}

6131

967

6132

# inform user

6133

warn "[Info] Processing $specifiedFile ...\n" unless $flags{display} & DISPLAY_NOINFO;

6134

511

6135

# init input stack

6136

@inputStack=([]);

6137

12287

6138

# init nesting stack

6139

@nestedSourcefiles=($file);

6140

1666

6141

# update source file nesting level hint

6142

_predeclareVariables({_SOURCE_LEVEL=>scalar(@nestedSourcefiles)});

6143

246

6144

# update file hint

6145

$sourceFile=$file;

6146

5419

6147

309

# open file and make the new handle the parsers input

6148

open($inHandle, $file) or confess("[Fatal] Could not open input file $file.\n");

6149

binmode($inHandle);

6150

6151

595

# store the filename in the list of opened sources, to avoid circular reopening

6152

# (it would be more perfect to store the complete path, is there a module for this?)

6153

$openedSourcefiles{$file}=1;

6154

7165

6155

# change into the source directory

6156

chdir(dirname($file));

6157

2395

6158

100

565

# (cleanup and) read old checksums as necessary

6159

my $cachefile=sprintf(".%s.ppcache", basename($file));

6160

if (($flags{cache} & CACHE_CLEANUP) and -e $cachefile)

6161

244

{

6162

warn " Resetting paragraph cache for $specifiedFile.\n" unless $flags{display} & DISPLAY_NOINFO;

6163

100

466

unlink($cachefile);

6164

}

6165

185

if (($flags{cache} & CACHE_ON) and -e $cachefile)

6166

{

6167

$checksums=retrieve($cachefile) ;

6168

#use Data::Dumper; warn Dumper($checksums);

6169

2739

6170

# clean up old format caches

6171

unless (

6172

exists $checksums->{sha1_base64('version')}

6173

and $checksums->{sha1_base64('version')}>=0.38

6174

6175

and exists $checksums->{sha1_base64('constants')}

6176

and $checksums->{sha1_base64('constants')}==$PerlPoint::Constants::VERSION

6177

6178

and exists $checksums->{sha1_base64('Storable')}

6179

and $checksums->{sha1_base64('Storable')}==$Storable::VERSION

6180

)

6181

{

6182

warn " Paragraph cache for $specifiedFile is rebuilt because of an old format.\n" unless $flags{display} & DISPLAY_NOINFO;

6183

unlink($cachefile);

6184

$checksums={};

6185

}

6186

}

6187

100

445

6188

# store cache builder version and constant declarations version

6189

if ($flags{cache} & CACHE_ON)

6190

{

6191

$checksums->{sha1_base64('version')}=$PerlPoint::Parser::VERSION;

6192

$checksums->{sha1_base64('constants')}=$PerlPoint::Constants::VERSION;

6193

$checksums->{sha1_base64('Storable')}=$Storable::VERSION;

6194

}

6195

201

1857

6196

# store a document start directive (done here to save memory)

6197

push(@{$resultStreamRef->[STREAM_TOKENS]}, [\%docHints, DIRECTIVE_DOCUMENT, DIRECTIVE_START, basename($file)]);

6198

177

313

6199

# update tag finish memory by the way

6200

_updateTagFinishMem(scalar(@{$resultStreamRef->[STREAM_TOKENS]}));

6201

643

6202

# enter first (and most common) lexer state

6203

_stateManager(STATE_DEFAULT);

6204

100

229

6205

# flag that the next paragraph can be checksummed, if so

6206

$flags{checksum}=1 if $flags{cache} & CACHE_ON;

6207

293

6208

# set a timestamp, if helpful

6209

$flags{started}=time unless $flags{display} & DISPLAY_NOINFO;

6210

2931

6211

# parse input

6212

$rc=($rc and $me->YYParse(yylex=>\&_lexer, yyerror=>\&_Error, yydebug => ($flags{trace} & TRACE_PARSER) ? 0x1F : 0x00));

6213

308

6214

# stop time, if necessary

6215

warn "\n $specifiedFile was parsed in ", time-$flags{started}, " seconds.\n" unless $flags{display} & DISPLAY_NOINFO;

6216

2142

6217

# store a document completion directive (done here to save memory)

6218

push(@{$resultStreamRef->[STREAM_TOKENS]}, [\%docHints, DIRECTIVE_DOCUMENT, DIRECTIVE_COMPLETE, basename($file)]);

6219

108

6220

# reset the input handle and flags

6221

$readCompletely=0;

6222

431

6223

# store checksums, if necessary

6224

store($checksums, $cachefile) if ($flags{cache} & CACHE_ON)

6225

and $flags{cached}

6226

and defined $checksums and %$checksums;

6227

6969

6228

1090

# close the input file

6229

close($inHandle);

6230

$inHandle=new IO::File;

6231

6209

6232

# back to startup directory

6233

chdir($startupDirectory);

6234

}

6235

6236

1273

6237

# make a simple helper backend object

6238

my $helperBackend=new PerlPoint::Backend(

6239

name => 'parsers helper backend',

6240

display => DISPLAY_NOINFO+DISPLAY_NOWARN,

6241

6242

trace => TRACE_NOTHING,

6243

);

6244

949

6245

419

# get toc

6246

$helperBackend->bind($resultStreamRef);

6247

my $toc=$helperBackend->toc;

6248

100

510

6249

# store headlines as anchors, if necessary

6250

if (@$toc and $flags{headlineLinks})

6251

{

6252

# scopies

6253

my ($headlineNr, @headlinePath)=(0);

6254

6255

foreach (@$toc)

6256

{

6257

# update headline counter

6258

$headlineNr++;

6259

6260

# get data

6261

my ($level, $title)=@$_;

6262

6263

# skip empty headlines

6264

next unless $title;

6265

6266

# update headline path and numbers

6267

$headlinePath[$level]=$title;

6268

6269

# store both plain and composite headlines in the anchor object

6270

$anchors->add($title, $title, $headlineNr);

6271

$anchors->add(join('|', map {defined($_) ? $_ : ''} @headlinePath[$_..$level]), $title, $headlineNr) for (1..$level-1);

6272

}

6273

}

6274

6275

100

180

# add complete headline titles to streamed headline tokens,

6276

# move abbreviation, docstream and variable hints into data section

6277

if (@$toc)

6278

{

6279

# scopy

6280

my (@headlinePath, @shortcutPath, @levelPath, @pagenumPath);

120

490

6281

6282

for (my $index=0; $index<=$#{$toc}; ++$index)

6283

217

{

6284

# build a more readable shortcut

6285

my $ref=$resultStreamRef->[STREAM_TOKENS][$resultStreamRef->[STREAM_HEADLINES][$index]];

6286

335

220

6287

# get toc data

6288

my ($level, $title)=@{$toc->[$index]};

6289

6290

423

# adapt arrays to get rid of previous data - important in case someone skips several levels

6291

# (jumping from level 5 to 100 etc.)

6292

$#headlinePath=$#shortcutPath=$#levelPath=$#pagenumPath=$level;

6293

179

6294

100

332

# update headline pathes and numbers

6295

155

$headlinePath[$level]=$title;

6296

161

$shortcutPath[$level]=$ref->[0]{shortcut} ? $ref->[0]{shortcut} : $title;

6297

$levelPath[$level]++;

6298

232

$pagenumPath[$level]=$index+1; # real page number, no index

6299

305

6300

100

6912

my $docstreams=delete($ref->[0]{docstreams});

6301

my $variables=delete($ref->[0]{vars});

6302

push (

6303

@$ref,

6304

$toc->[$index][1],

6305

delete($ref->[0]{shortcut}),

6306

$flags{docstreaming}==DSTREAM_DEFAULT ? [sort keys %$docstreams] : {},

6307

6308

# store headline path data in the streamed token

6309

[

6310

dclone([@headlinePath[1..$level]]),

6311

dclone([@shortcutPath[1..$level]]),

6312

dclone([@levelPath[1..$level]]),

6313

dclone([@pagenumPath[1..$level]]),

6314

$variables,

6315

6316

);

6317

}

6318

}

6319

100

324

6320

# finish tags, if necessary

6321

if (@$pendingTags==3)

6322

{

6323

# get number of tokens

6324

my $lastIndex=$#{$resultStreamRef->[STREAM_TOKENS]};

6325

6326

# handle all marked sections

6327

foreach my $section (@{$pendingTags->[2]})

6328

{

6329

# scan the stream till all pending tags were handled,

6330

# begin as near as possible

6331

for (my $position=$section->[0]; $position<=$lastIndex; $position++)

6332

176

{

6333

# get token

6334

my $token=$resultStreamRef->[STREAM_TOKENS][$position];

6335

100

140

6336

# skip everything except tag beginners of tags with finish hooks

6337

next unless ref($token)

6338

and $token->[STREAM_DIR_TYPE]==DIRECTIVE_TAG

6339

and $token->[STREAM_DIR_STATE]==DIRECTIVE_START

6340

and exists $tagsRef->{$token->[STREAM_DIR_DATA]}{finish};

6341

135

6342

# make an option hash

6343

my $options=dclone($token->[STREAM_DIR_DATA+1]);

6344

6345

# call hook function (use eval() to guard yourself)

6346

my $rc;

6347

eval {$rc=&{$tagsRef->{$token->[STREAM_DIR_DATA]}{finish}}($options, $anchors, join('-', @headlineIds))};

6348

6349

# check result

6350

unless ($@)

6351

{

6352

{

6353

# Error? (Treat syntactic errors as semantic ones at this point to give PARSING_FAILED a meaning.)

6354

++$_semerr, last if $rc==PARSING_ERROR or $rc==PARSING_FAILED;

6355

6356

# update options (might be modified, and checking for a difference

6357

# might take more time then just copying the replied values)

6358

$token->[STREAM_DIR_DATA+1]=$options;

6359

6360

# all right? (several values just mean "ok" at this point)

6361

last if $rc==PARSING_OK or $rc==PARSING_COMPLETED;

6362

6363

# backend hints to store?

6364

$token->[STREAM_DIR_HINTS]{ignore}=1, last if $rc==PARSING_IGNORE;

6365

$token->[STREAM_DIR_HINTS]{hide}=1, last if $rc==PARSING_ERASE;

6366

6367

# something is wrong here

6368

warn "[Warn] Tags ", $token->[STREAM_DIR_DATA], " tag finish hook replied unexpected result $rc, ignored.\n";

6369

}

6370

}

6371

else

6372

{warn "[Warn] Error in tags ", $token->[STREAM_DIR_DATA], " finish hook (ignored): $@\n"}

6373

6374

# update counter and leave loop if all pending tags in this section were handled

6375

last unless --$section->[1];

6376

}

6377

}

6378

}

6379

6380

# clean up

6381

undef $pendingTags;

6382

6383

100

566

6384

# success?

6385

if ($rc and not $_semerr)

6386

344

{

6387

# display a summary

6388

warn <

6389

6390

[Info] Input ok.

6391

6392

Statistics:

6393

-----------

6394

${\(_statisticsHelper(DIRECTIVE_HEADLINE))},

6395

${\(_statisticsHelper(DIRECTIVE_TEXT))},

6396

${\(_statisticsHelper(DIRECTIVE_UPOINT))},

6397

${\(_statisticsHelper(DIRECTIVE_OPOINT))},

6398

${\(_statisticsHelper(DIRECTIVE_DPOINT))},

6399

${\(_statisticsHelper(DIRECTIVE_BLOCK))},

6400

${\(_statisticsHelper(DIRECTIVE_VERBATIM))},

6401

${\(_statisticsHelper(DIRECTIVE_TAG))}

6402

${\(_statisticsHelper(DIRECTIVE_LIST_RSHIFT))},

6403

${\(_statisticsHelper(DIRECTIVE_LIST_LSHIFT))},

6404

and ${\(_statisticsHelper(DIRECTIVE_COMMENT))} were detected.

6405

6406

EOM

6407

216

6408

# add cache informations, if necessary

6409

warn ' ' x length('[Info] '), int(100*$statistics{cache}[1]/$statistics{cache}[0]+0.5), "% of all checked paragraphs were restored from cache.\n\n" if $flags{cache} & CACHE_ON and not $flags{display} & DISPLAY_NOINFO;

6410

}

6411

else

6412

{

100

6413

# display a summary

6414

warn "[Info] Input contains $_semerr semantic error", $_semerr>1?'s':'', ".\n" if $_semerr;

6415

}

6416

176

6417

# inform user

6418

warn "[Info] Parsing completed.\n\n" unless $flags{display} & DISPLAY_NOINFO;

6419

100

1347

6420

# reply success state

6421

$rc and not $_semerr;

6422

}

6423

6424

6425

# report a semantic error, terminate process if necessary

6426

sub _semerr

6427

206

{

6428

my $parser=shift;

6429

warn "[Error ", ++$_semerr, "] ", @_, "\n";

6430

$parser->YYAbort if $flags{criticalSemantics};

6431

}

6432

6433

# ------------------------------------------------------

6434

# A tiny helper function intended for internal use only.

6435

# ------------------------------------------------------

6436

sub _statisticsHelper

6437

{

6438

# get and check parameters

6439

my ($type)=@_;

6440

confess "[BUG] Missing type parameter.\n" unless defined $type;

6441

6442

# declare variables

6443

my ($nr)=(exists $statistics{$type} and $statistics{$type}) ? $statistics{$type} : 0;

6444

6445

# reply resulting string

6446

join('', "$nr ", $paragraphTypeStrings{$type}, $nr==1 ? '' : 's');

6447

}

6448

6449

sub _updateChecksums

6450

389

1105

{

6451

389

1208

# get and check parameters

6452

389

1400

my ($streamPart, $parserReinvokationHint)=@_;

6453

confess "[BUG] Missing stream part parameter.\n" unless defined $streamPart;

6454

confess "[BUG] Stream part parameter is no reference.\n" unless ref($streamPart);

6455

389

100

2080

6456

# certain paragraph types are not cached intentionally

6457

return if not ($flags{cache} & CACHE_ON)

6458

or exists {

6459

DIRECTIVE_COMMENT() => 1,

6460

100

542

}->{$streamPart->[0][STREAM_DIR_TYPE]};

6461

6462

46084

if (exists $flags{checksummed} and $flags{checksummed})

100

6463

{

6464

$checksums->{$sourceFile}{$flags{checksummed}[0]}=[

6465

dclone($streamPart),

6466

$flags{checksummed}[2],

6467

$parserReinvokationHint ? $parserReinvokationHint : (),

6468

defined $flags{checksummed}[3] ? $macroChecksum : (),

6469

defined $flags{checksummed}[4] ? $varChecksum : (),

6470

$anchors->reportNew,

6471

];

6472

303

# use Data::Dumper;

6473

# warn Dumper($streamPart);

6474

$flags{checksummed}=undef;

6475

272

6476

# note that something new was cached

6477

$flags{cached}=1;

6478

}

6479

}

6480

6481

6482

# --------------------------------------------------------

6483

# Extend all table rows to the number of columns found

6484

# in the first table line ("table headline"). On request,

6485

# automatically format the first table line as "headline".

6486

# --------------------------------------------------------

6487

sub _normalizeTableRows

6488

{

6489

# get and check parameters

6490

my ($stream, $autoHeadline)=@_;

6491

confess "[BUG] Missing stream part reference parameter.\n" unless defined $stream;

6492

confess "[BUG] Stream part reference parameter is no array reference.\n" unless ref($stream) eq 'ARRAY';

6493

confess "[BUG] Missing headline mode parameter.\n" unless defined $autoHeadline;

6494

6495

# declare variables

6496

my ($refColumns, $maxColumns, $columns, $nested, @flags, @improvedStream)=(0, 0, 0.5, 0, 1);

6497

100

122

6498

# remove whitespaces at the beginning and end of the stream, if necessary

6499

shift(@$stream) if $stream->[0]=~/^\s*$/; $stream->[0]=~s/^\s+//;

6500

pop(@$stream) if $stream->[-1]=~/^\s*$/; $stream->[-1]=~s/\s+$//;

6501

6502

# process the received stream

6503

foreach (@$stream)

6504

586

100

4489

{

100

6505

# search for *embedded* tables - which are already normalized!

6506

$nested+=($_->[STREAM_DIR_STATE]==DIRECTIVE_START ? 1 : -1)

6507

if ref($_) eq 'ARRAY' and $_->[STREAM_DIR_TYPE]==DIRECTIVE_TAG and $_->[STREAM_DIR_DATA] eq 'TABLE';

6508

586

100

1227

6509

# Inside an embedded table? Just pass the stream unchanged then.

6510

push(@improvedStream, $_), next if $nested;

6511

552

1898

6512

552

100

1679

# check state, set flags

6513

552

100

2217

$flags[1]=(ref($_) eq 'ARRAY' and $_->[STREAM_DIR_TYPE]==DIRECTIVE_TAG);

6514

552

100

1888

$flags[2]=($flags[1] and $_->[STREAM_DIR_DATA] eq 'TABLE_COL');

6515

552

100

1752

$flags[3]=($flags[1] and $_->[STREAM_DIR_STATE]==DIRECTIVE_COMPLETE and $_->[STREAM_DIR_DATA] eq 'TABLE_ROW');

6516

$flags[4]=1 if $flags[2] and $_->[STREAM_DIR_STATE]==DIRECTIVE_START;

6517

$flags[4]=0 if $flags[2] and $_->[STREAM_DIR_STATE]==DIRECTIVE_COMPLETE;

6518

552

100

1106

6519

# update counter of current row columns

6520

$columns+=0.5 if $flags[2];

6521

552

100

1662

6522

# end of column reached?

6523

if ($flags[2] and not $flags[4])

6524

{

6525

128

519

# remove all trailing whitespaces in the last recent data entry,

6526

128

100

331

# remove data which becomes empty this way

6527

$improvedStream[-1]=~s/\s+$//;

6528

pop(@improvedStream) unless length($improvedStream[-1]);

6529

}

6530

552

100

2596

6531

# first data after opening a new column?

6532

if ($flags[4] and not $flags[2])

6533

117

146

{

6534

# reset flag

6535

$flags[4]=0;

6536

117

352

6537

117

100

313

# remove all leading whitespaces, skip data which becomes empty this way

6538

s/^\s+//;

6539

next unless length($_);

6540

}

6541

466

100

807

6542

# table headline row?

6543

if ($flags[0])

6544

142

100

675

{

146

6545

# ok: mark columns as headline parts if necessary, take other elements unchanged

6546

push(@improvedStream, ($flags[2] and $autoHeadline) ? [@{$_}[STREAM_DIR_HINTS .. STREAM_DIR_STATE], 'TABLE_HL'] : $_);

6547

# at the end of this first row, marks that it is reached, store the number

6548

142

100

380

# of its columns as a reference for the complete table, and reset the column counter

6549

# (which will be used slightly differently in the following lines)

6550

$flags[0]=0, $refColumns=$maxColumns=$columns, $columns=0 if $flags[3];

6551

}

6552

else

6553

{

6554

# this is a content row (take care to preserve the order of operations here)

6555

324

100

633

6556

# end of table row reached?

6557

if ($flags[3])

6558

{

6559

# yes: insert additional columns, if necessary

6560

push(

6561

@improvedStream,

6562

137

[{}, DIRECTIVE_TAG, DIRECTIVE_START, 'TABLE_COL'],

6563

[{}, DIRECTIVE_TAG, DIRECTIVE_COMPLETE, 'TABLE_COL'],

6564

) for 1 .. ($refColumns-$columns);

6565

6566

# reset column counter

6567

$columns=0;

6568

}

6569

324

633

6570

# update maximum number of columns, if necessary

6571

$maxColumns=$columns if $columns>$maxColumns;

6572

324

700

6573

# in any case, copy this stream part

6574

push(@improvedStream, $_);

6575

}

6576

}

6577

260

6578

# replace original stream by the improved variant

6579

@$stream=@improvedStream;

6580

166

6581

# supply the number of columns in the table row *and* the maximum number of columns

6582

($refColumns, $maxColumns);

6583

}

6584

6585

6586

# predeclare variables

6587

sub _predeclareVariables

6588

105

982

{

6589

105

1213

# get and check parameters

6590

105

1445

my ($declarations, $preserveNames)=@_;

6591

confess "[BUG] Missing declaration parameter.\n" unless defined $declarations;

6592

confess "[BUG] Declaration parameter is no hash reference.\n" unless ref($declarations) eq 'HASH';

6593

6594

105

722

# transform variable names, if necessary

105

674

6595

105

100

1773

{

270

100

816

270

2275

6596

my $c=0;

6597

%$declarations=map {$c++; $c%2 ? uc : $_} %$declarations unless $preserveNames;

6598

}

6599

105

1528

484

6600

# handle every setting (keys are sorted for test puposes only, to make the stream reproducable)

6601

foreach my $var (sort {$a cmp $b} keys %$declarations)

6602

143

2857

{

6603

# check data format

6604

confess "[BUG] Predeclared variable $var is no scalar.\n" if ref($declarations->{$var});

6605

143

1254

6606

# store the variable - with an uppercased name

6607

$variables{$var}=$declarations->{$var};

6608

143

100

707

264

6609

# propagate the setting to the stream, if necessary

6610

push(@{$resultStreamRef->[STREAM_TOKENS]}, [{}, DIRECTIVE_VARSET, DIRECTIVE_START, {var=>$var, value=>$declarations->{$var}}]) if $flags{var2stream};

6611

143

100

1310

6612

# make the new variable setting available to embedded Perl code, if necessary

6613

414

if ($safeObject)

16640

6614

100

183

{

2379

6615

no strict 'refs';

6616

${join('::', ref($safeObject) ? $safeObject->root : 'main', $var)}=$declarations->{$var};

6617

}

6618

}

6619

105

2566

105

1225

6620

# update tag finish memory by the way

6621

_updateTagFinishMem(scalar(@{$resultStreamRef->[STREAM_TOKENS]}));

6622

}

6623

6624

6625

# update tag finish memory

6626

sub _updateTagFinishMem

6627

523

1294

{

6628

523

2515

# get and check parameters

6629

my ($lastKnownStreamIndex)=@_;

6630

confess "[BUG] Missing last known stream index parameter.\n" unless defined $lastKnownStreamIndex;

6631

523

100

1778

6632

# update tag finish memory, if necessary

6633

if ($pendingTags->[1])

6634

{

6635

# store current collection

6636

push(@{$pendingTags->[2]}, [@{$pendingTags}[0, 1]]);

6637

6638

# reset tag counter

6639

$pendingTags->[1]=0;

6640

}

6641

523

1257

6642

# in any case, update the "last known index" memory

6643

$pendingTags->[0]=$lastKnownStreamIndex;

6644

}

6645

6646

6647

6648

# set import filter, if necessary (by setting an import function - a user function is *not* overwritten!)

6649

sub _setImportFilter

6650

106

{

6651

142

# get and check parameters

6652

139

my ($parser, $optionHash)=@_;

6653

176

confess "[BUG] Missing parser parameter.\n" unless $parser;

6654

confess "[BUG] Missing option hash parameter.\n" unless defined $optionHash;

6655

confess "[BUG] Option hash parameter is no hash reference.\n" unless ref($optionHash) eq 'HASH';

6656

571

6657

# anything to do?

6658

if (

6659

not exists $optionHash->{ifilter} # there is no functional import filter set yet

6660

and exists $optionHash->{import} # but there is a type specific import filter set yet

6661

and not ( # and there is not ...

6662

exists $flags{ifilters}{lc($optionHash->{import})} # ... a general import filter known yet

6663

and not defined $flags{ifilters}{lc($optionHash->{import})} # ... which flags that there is no such filter

6664

)

6665

)

6666

{

6667

# parser options allow to use input filters of other languages, if this is the case we find that the

6668

# value of the general import filter is a special string which holds the name of that language

6669

my $filterLang=lc(

6670

(

6671

exists $flags{ifilters}{lc($optionHash->{import})}

6672

and $flags{ifilters}{lc($optionHash->{import})}=~/^MAP:\s*(\w+)$/

6673

) ? $flags{ifilters}{lc($1)} : $optionHash->{import}

6674

);

6675

6676

# first time we need this import filter?

6677

unless (exists $flags{ifilters}{$filterLang})

6678

{

6679

# so, there is a chance to find such a filter via general modules, search for such a module

6680

eval

6681

219

{

67750

6682

# no strict subs

6683

no strict;

6684

6685

# build module name

6686

my $moduleName=join('::', 'PerlPoint::Import', uc($filterLang));

6687

6688

# try to load the module

6689

my $evalCode="require $moduleName;";

6690

ref($safeObject) ? $safeObject->reval($evalCode) : eval $evalCode;

6691

die $@ if $@;

6692

6693

# check for the import function specified by the API, store the code reference to the function

6694

# found or the undefined value otherwise, which will avoid repeated searches (store it both

6695

# for the filter language and the file language, which might differ due to filter mapping)

6696

$evalCode="exists \$${moduleName}::{importFilter}";

6697

$flags{ifilters}{lc($optionHash->{import})}=$flags{ifilters}{$filterLang}=join('::', $moduleName, 'importFilter()') if ref($safeObject) ? $safeObject->reval($evalCode) : eval $evalCode;

6698

};

6699

6700

# check success

6701

$parser->_semerr("Could not load $optionHash->{import} import filter module: $@."), return undef if $@;

6702

}

6703

6704

# now, set a functional filter, if possible

6705

$optionHash->{ifilter}=$flags{ifilters}{$filterLang}

6706

if exists $flags{ifilters}{$filterLang} and defined $flags{ifilters}{$filterLang};

6707

}

6708

282

6709

# flag success

6710

6711

}

6712

6713

# perform paragraph filter calls

6714

sub _pfilterCall

6715

{

6716

# get and check parameters

6717

my ($parser, $filters, $pstream, $lineNr)=@_;

6718

confess "[BUG] Missing parser parameter.\n" unless $parser;

6719

confess "[BUG] Missing filter list.\n" unless $filters;

6720

confess "[BUG] Filter list is no array reference.\n" unless ref($filters) eq 'ARRAY';

6721

confess "[BUG] Missing paragraph stream.\n" unless $pstream;

6722

confess "[BUG] Paragraph stream is no array reference.\n" unless ref($pstream) eq 'ARRAY';

6723

confess "[BUG] Missing line number.\n" unless $lineNr;

6724

6725

6726

# declare and init variables

6727

my ($streamRef, %tableCounters);

6728

$retranslationBuffer='';

6729

100

6730

# build retranslator, if necessary

6731

unless ($retranslator)

6732

{

6733

# scopy

6734

my ($verbatimFlag)=(0);

6735

220

6736

# the retranslator is a backend object

6737

$retranslator=new PerlPoint::Backend(

6738

name => 'retranslator',

6739

display => DISPLAY_NOINFO+DISPLAY_NOWARN,

6740

trace => TRACE_NOTHING,

6741

);

6742

6743

# various callbacks perform the retranslation

6744

$retranslator->register(DIRECTIVE_SIMPLE, sub

6745

144

{

6746

# get parameters

6747

my ($opcode, $mode, @contents)=@_;

6748

6749

# add contents to the source text collection,

6750

114

# double backslashes (if they are here, they were guarded originally),

6751

183

# and restore ">" characters as if they were guarded

6752

207

(my $text=join('', @contents));

6753

$text=~s/([\\>])/\\$1/g unless $verbatimFlag;

6754

$retranslationBuffer.=$text;

6755

}

6756

);

6757

6758

$retranslator->register(DIRECTIVE_HEADLINE, sub

6759

{

6760

# get parameters

6761

my ($opcode, $mode, $level)=@_;

6762

100

6763

# add preceeding "=" characters

6764

$retranslationBuffer.=('=' x $level) if $mode==DIRECTIVE_START;

6765

}

6766

);

6767

6768

$retranslator->register(DIRECTIVE_VERBATIM, sub

6769

{

6770

# get parameters

6771

my ($opcode, $mode)=@_;

6772

6773

# cover contents

6774

$verbatimFlag=1, $retranslationBuffer.="<

6775

$verbatimFlag=0, $retranslationBuffer.="EOE\n" if $mode==DIRECTIVE_COMPLETE;

6776

}

6777

);

6778

6779

my $handleListPoint=sub

6780

{

6781

# get parameters

6782

my ($opcode, $mode, @data)=@_;

6783

6784

# act mode dependend

6785

if ($mode==DIRECTIVE_START)

6786

{$retranslationBuffer.=$opcode==DIRECTIVE_UPOINT ? '* ' : $opcode==DIRECTIVE_OPOINT ? '# ' : ':';}

6787

else

6788

{$retranslationBuffer.="\n\n"}

6789

};

6790

6791

my $handleDListPointItem=sub

6792

{

6793

# get parameters

6794

my ($opcode, $mode, @data)=@_;

6795

6796

# complete the item part if necessary

6797

$retranslationBuffer.=': ' if $mode==DIRECTIVE_COMPLETE;

6798

};

6799

6800

my $handleListShift=sub

6801

{

6802

# get parameters

6803

my ($opcode, $mode, $offset)=@_;

6804

6805

# anything to do?

6806

$retranslationBuffer.=join('',

6807

$opcode==DIRECTIVE_LIST_RSHIFT ? '>' : '<',

6808

"$offset\n\n",

6809

) if $mode==DIRECTIVE_START;

6810

};

6811

6812

$retranslator->register($_, $handleListPoint) foreach (DIRECTIVE_UPOINT, DIRECTIVE_OPOINT, DIRECTIVE_DPOINT);

6813

$retranslator->register($_, $handleListShift) foreach (DIRECTIVE_LIST_LSHIFT, DIRECTIVE_LIST_RSHIFT);

6814

$retranslator->register(DIRECTIVE_DPOINT_ITEM, $handleDListPointItem);

6815

6816

$retranslator->register(DIRECTIVE_TAG, sub

6817

{

6818

# get parameters

6819

my ($opcode, $mode, $tag, $settings, $bodyHint)=@_;

6820

6821

# table tags need special care, is it one?

6822

unless ($tag=~/^TABLE/)

6823

{

6824

# it can happen that perl complains about an undefined value here

6825

# even if no such value is to be find in debugging

6826

local($^W)=0;

6827

6828

# act mode dependend

6829

$retranslationBuffer.=$mode==DIRECTIVE_START ? join('', "\\$tag", (defined $settings and %$settings and grep(!/^__/, keys %$settings)) ? join('', '{', join(' ', map {qq($_="$settings->{$_}")} grep(!/^__/, keys %$settings)), '}') : (), ((defined $bodyHint and $bodyHint) ? '<' : ())) : ((defined $bodyHint and $bodyHint) ? '>' : ());

6830

}

6831

else

6832

{

6833

# TABLE declared by paragraph?

6834

if ($tag eq 'TABLE' and exists $settings->{__paragraph__})

6835

{

6836

# translate TABLE into paragraph start or completion

6837

$retranslationBuffer.=$mode==DIRECTIVE_START ? join('', '@', $settings->{separator}, "\n") : '';

6838

# init counters, store separators

6839

@tableCounters{qw(row col rowsep colsep)}=(0, 0, "\n", " $settings->{separator} ");

6840

}

6841

# TABLE declared by tags?

6842

elsif ($tag eq 'TABLE')

6843

{

6844

# translate TABLE into TABLE and END_TABLE

6845

$retranslationBuffer.=$mode==DIRECTIVE_START ? join('', '\TABLE{', join(' ', map {qq($_="$settings->{$_}")} grep(!/^__/, keys %$settings)), '}', $settings->{rowseparator} eq '\\\n' ? "\n" : '') : join('', $settings->{rowseparator} eq '\\\n' ? "\n" : '', '\END_TABLE');

6846

# init counters, store separators

6847

@tableCounters{qw(row col rowsep colsep)}=(0, 0, $settings->{rowseparator} eq '\\\n' ? "\n" : $settings->{rowseparator}, $settings->{separator} eq '\\\n' ? "\n" : " $settings->{separator} ");

6848

}

6849

# TABLE_ROW?

6850

elsif ($tag eq 'TABLE_ROW')

6851

{

6852

# we only need to act at startup

6853

if ($mode==DIRECTIVE_START)

6854

{

6855

# write a row separator if there was a row before

6856

$retranslationBuffer.=$tableCounters{rowsep} if $tableCounters{row};

6857

# update row counter, reset column counter

6858

$tableCounters{row}++;

6859

$tableCounters{col}=0;

6860

}

6861

}

6862

# TABLE_HL or TABLE_COL?

6863

elsif ($tag=~/TABLE_(HL|COL)/)

6864

{

6865

# we only need to act at startup

6866

if ($mode==DIRECTIVE_START)

6867

{

6868

# write a column separator if there was a column before

6869

$retranslationBuffer.=$tableCounters{colsep} if $tableCounters{col};

6870

# update row counter

6871

$tableCounters{col}++;

6872

}

6873

}

6874

}

6875

}

6876

);

6877

}

6878

6879

# embed paragraph stream into a structure looking like a complete stream

6880

@{$streamRef}[

6881

STREAM_IDENT,

6882

STREAM_TOKENS,

6883

STREAM_HEADLINES,

6884

]=(

6885

'__PerlPoint_stream__', # stream identifier;

6886

$pstream, # base stream: paragraph stream;

6887

[], # headline stream (dummy);

6888

);

6889

6890

# retranslate paragraph

6891

$retranslator->run($streamRef);

6892

6893

# init paragraph text

6894

# $retranslationBuffer=join('', @{$pstream}[1..($#{$pstream}-1)]);

6895

6896

# warn "BUFFER: $retranslationBuffer\n";

6897

6898

foreach my $perl (@$filters)

6899

{

6900

# we provide the paragraph text simply - for a general solution, we need to use an object

6901

285

# of a handy subclass of PerlPoint::Backend (still to be written)

108

13410

6902

{

6903

152

no strict 'refs';

6904

${join('::', ref($safeObject) ? $safeObject->root : 'main', '_pfilterText')}=$retranslationBuffer;

6905

${join('::', ref($safeObject) ? $safeObject->root : 'main', '_pfilterType')}=$paragraphTypeStrings{$pstream->[0][1]};

6906

}

6907

140

6908

# inform user

6909

warn qq([Trace] $sourceFile, line $lineNr: Running paragraph filter "$perl".\n) if $flags{trace} & TRACE_ACTIVE;

6910

6911

# call the filter

6912

$retranslationBuffer=ref($safeObject) ? $safeObject->reval($perl) : eval(join(' ', '{package main; no strict;', $perl, '}'));

6913

10188

6914

# check result

6915

if ($@)

6916

{

6917

# inform user, if necessary

6918

_semerr($parser, qq($sourceFile, line $lineNr: paragraph filter "$perl" could not be evaluated: $@.));

6919

6920

# stop processing, flag error

6921

return undef;

6922

}

6923

}

6924

6925

# success: reply result (embed it into empty lines to avoid paragraph mismatch)

6926

defined $retranslationBuffer ? [("\n") x 2, split(/(\n)/, $retranslationBuffer), ("\n") x 2] : '';

6927

}

6928

6929

=pod

6930

6931

=head2 anchors()

6932

6933

A class method that supplied all anchors collected by the parser.

6934

6935

Example:

6936

6937

my $anchors=PerlPoint::Parser::anchors;

6938

6939

=cut

6940

sub anchors

6941

{$anchors;}

6942

6943

6944

6945

6946

# declare a helper package used for token "delay" after bodyless macros

6947

# (implemented the oo way to determine the data)

6948

package PerlPoint::Parser::DelayedToken;

6949

252

31895

6950

# even this tiny package needs modules!

6951

use Carp;

6952

6953

# make an object holding the token name and its value

6954

sub new

6955

{

6956

# get parameter

6957

my ($class, $token, $value)=@_;

6958

6959

# check parameters

6960

confess "[BUG] Missing class name.\n" unless $class;

6961

confess "[BUG] Missing token parameter.\n" unless $token;

6962

confess "[BUG] Missing token value parameter.\n" unless defined $value;

6963

6964

# build and reply object

6965

bless([$token, $value], $class);

6966

}

6967

6968

# reply token

6969

sub token {$_[0]->[0];}

6970

6971

# reply value

6972

sub value {$_[0]->[1];}

6973

6974

6975

6976

6977

# = POD TRAILER SECTION =================================================================

6978

6979

=pod

6980

6981

=head1 EXAMPLE

6982

6983

The following code shows a minimal but complete parser.

6984

6985

# pragmata

6986

use strict;

6987

6988

# load modules

6989

use PerlPoint::Parser;

6990

6991

# declare variables

6992

my (@streamData);

6993

6994

# build parser

6995

my ($parser)=new PerlPoint::Parser;

6996

# and call it

6997

$parser->run(

6998

stream => \@streamData,

6999

files => \@ARGV,

7000

);

7001

7002

=head1 NOTES

7003

7004

=head2 Converter namespace

7005

7006

It is suggested to B operating in namespace B. In order to emulate

7007

the behaviour of the B module by C in case a user wishes to get

7008

full Perl access for active contents, active contents needs to be executed in

7009

this namespace. Safe does not allow to change this, so the documented default

7010

for "saved" and "not saved" active contents I to be C. This means

7011

that both the parser and active contents will pollute C. Prevent from being

7012

effected by choosing a different converter namespace. The B

7013

hyrarchy is reserved for this purpose. The recommended namespace is

7014

C>, e.g. C.

7015

7016

=head2 Format

7017

7018

The PerlPoint format was initially designed by I,

7019

who wrote an HTML slide generator for it, too.

7020

7021

I added a number of additional, useful and interesting

7022

features to the original implementation. At a certain point, we

7023

decided to redesign the tool to make it a base for slide generation

7024

not only into HTML but into various document description languages.

7025

7026

The PerlPoint format implemented by this parser version is slightly

7027

different from the original design. Presentations written for Perl

7028

Point 1.0 will I pass the parser but can simply be converted

7029

into the new format. We designed the new format as a team of

7030

I, I and me.

7031

7032

=head2 Storable updates

7033

7034

From version 0.24 on the Storable module is a prerequisite of the

7035

parser package because Storable is used to store and retrieve cache

7036

data in files. If you update your Storable installation it I

7037

happen that its internal format changes and therefore stored cache

7038

data becomes unreadable. To avoid this, the parser automatically

7039

rebuilds existing caches in case of Storable updates.

7040

7041

=head1 FILES

7042

7043

If Is are used, the parser writes cache files where the initial

7044

sources are stored. They are named ..ppcache.

7045

7046

=head1 SEE ALSO

7047

7048

=over 4

7049

7050

=item PerlPoint::Backend

7051

7052

A frame class to write backends basing on the I.

7053

7054

=item PerlPoint::Constants

7055

7056

Constants used by parser functions and in the I.

7057

7058

=item PerlPoint::Tags

7059

7060

Tag declaration base class.

7061

7062

=item pp2sdf

7063

7064

A reference implementation of a PerlPoint converter, distributed with the parser package.

7065

7066

=item pp2html

7067

7068

The inital PerlPoint tool designed and provided by Tom Christiansen. A new translator

7069

by I using B.

7070

7071

=back

7072

7073

7074

=head1 SUPPORT

7075

7076

A PerlPoint mailing list is set up to discuss usage, ideas,

7077

bugs, suggestions and translator development. To subscribe,

7078

please send an empty message to perlpoint-subscribe@perl.org.

7079

7080

If you prefer, you can contact me via perl@jochen-stenzel.de

7081

as well.

7082

7083

7084

=head1 AUTHOR

7085

7086

7087

7088

7089

This module is free software, you can redistribute it and/or modify it

7090

under the terms of the Artistic License distributed with Perl version

7091

5.003 or (at your option) any later version. Please refer to the

7092

Artistic License that came with your Perl distribution for more

7093

details.

7094

7095

The Artistic License should have been included in your distribution of

7096

Perl. It resides in the file named "Artistic" at the top-level of the

7097

Perl source tree (where Perl was downloaded/unpacked - ask your

7098

system administrator if you dont know where this is). Alternatively,

7099

the current version of the Artistic License distributed with Perl can

7100

be viewed on-line on the World-Wide Web (WWW) from the following URL:

7101

http://www.perl.com/perl/misc/Artistic.html.

7102

7103

B is built using B a way that users

7104

have I to explicitly install B themselves. According

7105

to the copyright note of B I have to mention the following:

7106

7107

"The Parse::Yapp module and its related modules and shell

7108

7109

7110

7111

You may use and distribute them under the terms of either

7112

the GNU General Public License or the Artistic License, as

7113

specified in the Perl README file."

7114

7115

7116

=head1 DISCLAIMER

7117

7118

This software is distributed in the hope that it will be useful, but

7119

is provided "AS IS" WITHOUT WARRANTY OF ANY KIND, either expressed or

7120

implied, INCLUDING, without limitation, the implied warranties of

7121

MERCHANTABILITY and FITNESS FOR A PARTICULAR PURPOSE.

7122

7123

The ENTIRE RISK as to the quality and performance of the software

7124

IS WITH YOU (the holder of the software). Should the software prove

7125

defective, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR

7126

CORRECTION.

7127

7128

IN NO EVENT WILL ANY COPYRIGHT HOLDER OR ANY OTHER PARTY WHO MAY CREATE,

7129

MODIFY, OR DISTRIBUTE THE SOFTWARE BE LIABLE OR RESPONSIBLE TO YOU OR TO

7130

ANY OTHER ENTITY FOR ANY KIND OF DAMAGES (no matter how awful - not even

7131

if they arise from known or unknown flaws in the software).

7132

7133

Please refer to the Artistic License that came with your Perl

7134

distribution for more details.

7135

7136

=cut