File Coverage

1676
1677		First
1678		Perhaps*
1679		Always
1680		Any or None
1681		Probably**
1682		Finally
1683
1684
1685		use PDF::Reuse
1686
1687		prFile
1688		prInitVars
1689	prExtract
1690	prForm
1691	prInit
1692	prField
1693	prImage
1694	prAltJpeg
1695	prJpeg
1696	prFont
1697	prFontSize
1698	prTTFont
1699	prGraphState
1700	prAdd
1701	prText
1702	prJs
1703	prCompress
1704	prMbox
1705	prBookmark
1706	prStrWidth
1707	prLink
1708		prDoc
1709	prPage
1710	prSinglePage
1711		prEnd
1712
1713
1714		prDocDir*
1715	prLogDir*
1716
1717		prDocForm*
1718	prGetLogBuffer*
1719	prBar*
1720	prLog*
1721	prTouchUp*
1722	prVers*
1723	prCid*
1724	prId*
1725	prIdType*
1726
1727
1728
1729
1730		* = internal/ deprecated function
1731
1732
1733		** = not needed before prEnd or a new prFile
1734	In those cases prPage is automatically inserted
1735
1736

1737

1738

1739

1740

=end html

1741

1742

=head1 Mandatory Functions

1743

1744

=head2 prFile - define output

1745

1746

Alternative 1:

1747

1748

prFile ( $fileName );

1749

1750

Alternative 2 with parameters in an anonymous hash:

1751

1752

prFile ( { Name => $fileName,

1753

HideToolbar => 1, # 1 or 0

1754

HideMenubar => 1, # 1 or 0

1755

HideWindowUI => 1, # 1 or 0

1756

FitWindow => 1, # 1 or 0

1757

CenterWindow => 1 } ); # 1 or 0

1758

1759

Alternative 3:

1760

1761

prFile ( $r ); # For mod_perl 2 pass the request object

1762

1763

$fileName is optional, just like the rest of the parameters.

1764

File to create. If another file is current when this function is called, the first

1765

one is written and closed. Only one file is processed at a single moment. If

1766

$fileName is undefined, output is written to STDOUT.

1767

1768

HideToolbar, HideMenubar, HideWindowUI, FitWindow and CenterWindow control the

1769

way the document is initially displayed.

1770

1771

Look at any program in this documentation for examples. prInitVars() shows how

1772

this function could be used together with a web server.

1773

1774

=head2 prEnd - end/flush buffers

1775

1776

prEnd ()

1777

1778

When the processing is going to end, the buffers of the B file has to be written to the disc.

1779

If this function is not called, the page structure, xref part and so on will be

1780

lost.

1781

1782

Look at any program in this documentation for an example.

1783

1784

=head1 Optional Functions

1785

1786

=head2 prAdd - add "low level" instructions

1787

1788

prAdd ( $string )

1789

1790

With this command you can add whatever you want to the current content stream.

1791

No syntactical checks are made, but if you use an internal name, the module tries

1792

to add the resource of the "name object" to the "Resources" of current page.

1793

"Name objects" always begin with a '/'.

1794

1795

(In this documentation I often use talk about an "internal name". It denotes a

1796

"name object". When PDF::Reuse creates these objects, it assigns Ft1, Ft2, Ft3 ...

1797

for fonts, Ig1, Ig2, Ig3 for images, Fo1 .. for forms, Cs1 .. for Color spaces,

1798

Pt1 .. for patterns, Sh1 .. for shading directories, Gs0 .. for graphic state

1799

parameter dictionaries. These names are kept until the program finishes,

1800

and my ambition is also to keep the resources available in internal tables.)

1801

1802

This is a simple and very powerful function. You should study the examples and

1803

the "PDF-reference manual", if you want to use it.(When this text is written,

1804

a possible link to download it is:

1805

http://partners.adobe.com/asn/developer/acrosdk/docs.html)

1806

1807

This function is intended to give you detail control at a low level.

1808

1809

use PDF::Reuse;

1810

use strict;

1811

1812

prFile('myFile.pdf');

1813

my $string = "150 600 100 50 re\n"; # a rectangle

1814

$string .= "0 0 1 rg\n"; # blue (to fill)

1815

$string .= "b\n"; # fill and stroke

1816

prAdd($string);

1817

prEnd();

1818

1819

1820

=head2 prBookmark - define bookmarks

1821

1822

prBookmark($reference)

1823

1824

Defines a "bookmark". $reference refers to a hash or array of hashes which looks

1825

something like this:

1826

1827

{ text => 'Document',

1828

act => 'this.pageNum = 0; this.scroll(40, 500);',

1829

kids => [ { text => 'Chapter 1',

1830

act => '1, 40, 600'

1831

1832

{ text => 'Chapter 2',

1833

act => '10, 40, 600'

1834

}

1835

]

1836

}

1837

1838

Each hash can have these components:

1839

1840

text the text shown beside the bookmark

1841

act the action to be triggered. Has to be a JavaScript action.

1842

(Three simple numbers are translated to page, x and y in the

1843

sentences: this.pageNum = page; this.scroll(x, y); )

1844

kids will have a reference to another hash or array of hashes

1845

close if this component is present, the bookmark will be closed

1846

when the document is opened

1847

color 3 numbers, RGB-colors e.g. '0.5 0.5 1' for light blue

1848

style 0, 1, 2, or 3. 0 = Normal, 1 = Italic, 2 = Bold, 3 = Bold Italic

1849

1850

Creating bookmarks for a document:

1851

1852

use PDF::Reuse;

1853

use strict;

1854

1855

my @pageMarks;

1856

1857

prFile('myDoc.pdf');

1858

1859

for (my $i = 0; $i < 100; $i++)

1860

{ prText(40, 600, 'Something is written');

1861

# ...

1862

my $page = $i + 1;

1863

my $bookMark = { text => "Page $page",

1864

act => "$i, 40, 700" };

1865

push @pageMarks, $bookMark;

1866

prPage();

1867

}

1868

prBookmark( { text => 'Document',

1869

close => 1,

1870

kids => \@pageMarks } );

1871

prEnd();

1872

1873

1874

Traditionally bookmarks have mainly been used for navigation within a document,

1875

but they can be used for many more things. You can e.g. use them to navigate within

1876

your data. You can let your users go to external links also, so they can "drill down"

1877

to other documents.

1878

1879

1880

1881

=head2 prCompress - compress/zip added streams

1882

1883

prCompress (1)

1884

1885

'1' here is a directive to compress all B streams of the current file. Streams

1886

which are included with prForm, prDocForm, prDoc or prSinglePage are not changed. New

1887

JavaScripts are also created as streams and compressed, if they are at least 100

1888

bytes long. The streams are compressed in memory, so probably there is a limit of

1889

how big they can be.

1890

1891

prCompress(); is a directive not to compress. This is default.

1892

1893

See e.g. "Starting to reuse" in the tutorial for an example.

1894

1895

=head2 prDoc - include pages from a document

1896

1897

prDoc ( $documentName, $firstPage, $lastPage )

1898

1899

or with the parameters in an anonymous hash:

1900

1901

prDoc ( { file => $documentName,

1902

first => $firstPage,

1903

last => $lastPage } );

1904

1905

Returns number of extracted pages.

1906

1907

If "first" is not given, 1 is assumed. If "last" is not given, you don't have any upper

1908

limit. N.B. The numbering of the pages differs from Acrobat JavaScript. In JavaScript

1909

the first page has index 0.

1910

1911

Adds pages from a document to the one you are creating.

1912

N.B. From version 0.32 of this module:

1913

If there are contents created with with prText, prImage,prAdd, prForm and so on,

1914

prDoc tries to put the contents on the first extracted page

1915

from the old document.

1916

1917

1918

If it is the first interactive

1919

component ( prDoc() or prDocForm() ) the interactive functions are kept and also merged

1920

with JavaScripts you have added, if any. But, if you specify a first page different than 1

1921

or a last page, no JavaScript are extracted from the document, because then there is a

1922

risk that an included JavaScript function might refer to something not included.

1923

1924

use PDF::Reuse;

1925

use strict;

1926

1927

prFile('myFile.pdf'); # file to make

1928

prJs('customerResponse.js'); # include a JavaScript file

1929

prInit('nameAddress(12, 150, 600);'); # init a JavaScript function

1930

prForm('best.pdf'); # page 1 from best.pdf

1931

prPage();

1932

prDoc('long.pdf'); # a document with 11 pages

1933

prForm('best.pdf'); # page 1 from best.pdf

1934

prText(150, 700, 'Customer Data'); # a line of text

1935

prEnd();

1936

1937

To extract pages 2-3 and 5-7 from a document and create a new document:

1938

1939

use PDF::Reuse;

1940

use strict;

1941

1942

prFile('new.pdf');

1943

prDoc( { file => 'old.pdf',

1944

first => 2,

1945

last => 3 });

1946

prDoc( { file => 'old.pdf',

1947

first => 5,

1948

last => 7 });

1949

prEnd();

1950

1951

1952

To add a form, image and page number to each page of an 16 pages long document

1953

(The document Battery.pdf is cropped so each page is fairly small) You could also have

1954

used prSinglePage, look at a very similar example under that function.

1955

1956

use PDF::Reuse;

1957

use PDF::Reuse::Util;

1958

use strict;

1959

1960

prFile('test.pdf');

1961

1962

my $pageNumber = 0;

1963

1964

for (my $page = 1; $page < 17; $page++)

1965

{ $pageNumber++;

1966

prForm( { file =>'Words.pdf',

1967

page => 5,

1968

x => 150,

1969

y => 150} );

1970

1971

prImage( { file =>'Media.pdf',

1972

page => 6,

1973

imageNo => 1,

1974

x => 450,

1975

y => 450 } );

1976

blackText();

1977

prText( 360, 250, $pageNumber);

1978

prDoc('Battery.pdf', $pageNumber, $pageNumber);

1979

}

1980

prEnd;

1981

1982

1983

=head2 prDocDir - set directory for produced documents

1984

1985

prDocDir ( $directoryName )

1986

1987

Sets directory for produced documents

1988

1989

use PDF::Reuse;

1990

use strict;

1991

1992

prDocDir('C:/temp/doc');

1993

prFile('myFile.pdf'); # writes to C:\temp\doc\myFile.pdf

1994

prForm('myFile.pdf'); # page 1 from ..\myFile.pdf

1995

prText(200, 600, 'New text');

1996

prEnd();

1997

1998

=head2 prDocForm - use an interactive page as a form

1999

2000

Alternative 1) You put your parameters in an anonymous hash (only B is really

2001

necessary, the others get default values if not given).

2002

2003

prDocForm ( { file => $pdfFile, # template file

2004

page => $page, # page number (of imported template)

2005

adjust => $adjust, # try to fill the media box

2006

effect => $effect, # action to be taken

2007

tolerant => $tolerant, # continue even with an invalid form

2008

x => $x, # $x points from the left

2009

y => $y, # $y points from the bottom

2010

rotate => $degree, # rotate

2011

size => $size, # multiply everything by $size

2012

xsize => $xsize, # multiply horizontally by $xsize

2013

ysize => $ysize } ) # multiply vertically by $ysize

2014

Ex.:

2015

my $internalName = prDocForm ( {file => 'myFile.pdf',

2016

page => 2 } );

2017

2018

Alternative 2) You put your parameters in this order

2019

2020

prDocForm ( $pdfFile, [$page, $adjust, $effect, $tolerant, $x, $y, $degree,

2021

$size, $xsize, $ysize] )

2022

2023

2024

Anyway the function returns in list context: B<$intName, @BoundingBox,

2025

$numberOfImages>, in scalar context: B<$internalName> of the form.

2026

2027

Look at prForm() for an explanation of the parameters.

2028

2029

N.B. Usually you shouldn't adjust or change size and proportions of an interactive

2030

page. The graphic and interactive components are independent of each other and there

2031

is a great risk that any coordination is lost.

2032

2033

This function redefines a page to an "XObject" (the graphic parts), then the

2034

page can be reused in a much better way. Unfortunately there is an important

2035

limitation here. "XObjects" can only have single streams. If the page consists

2036

of many streams, you should concatenate them first. Adobe Acrobat can do that.

2037

(If it is an important file, take a copy of it first. Sometimes the procedure fails.)

2038

Open the document with Acrobat. Then choose the the "TouchUp Text" tool (icon or

2039

from the tools menu). Select a line of text somewhere on the page. Right-click the

2040

mouse. Choose "Attributes".Change font size or anything else, and then you change

2041

it back to the old value. Save the document.

2042

If there was no text on the page, use some other "Touch Up" tool.

2043

Alternatively, use GhostScript to convert multi-stream PDFs (see prForm documentation

2044

for the command).

2045

2046

2047

use PDF::Reuse;

2048

use strict;

2049

2050

prDocDir('C:/temp/doc');

2051

prFile('newForm.pdf');

2052

prField('Mr/Ms', 'Mr');

2053

prField('First_Name', 'Lars');

2054

prDocForm('myFile.pdf');

2055

prFontSize(24);

2056

prText(75, 790, 'This text is added');

2057

prEnd();

2058

2059

(You can use the output from the example in prJs() as input to this example.

2060

Remember to save that file before closing it.)

2061

2062

2063

2064

=head2 prExtract - extract an object group

2065

2066

prExtract ( $pdfFile, $pageNo, $oldInternalName )

2067

2068

B, a "name"-object. This is the internal name you find in the original file.

2069

Returns a B<$newInternalName> which can be used for "low level" programming. You

2070

have better look at graphObj_pl and modules it has generated for the tutorial,

2071

e.g. thermometer.pm, to see how this function can be used.

2072

2073

When you call this function, the necessary objects will be copied to your new

2074

PDF-file, and you can refer to them with the new name you receive.

2075

2076

2077

=head2 prField - assign a value to an interactive field

2078

2079

prField ( $fieldName, $value )

2080

2081

B<$fieldName> is an interactive field in the document you are creating.

2082

It has to be spelled exactly the same way here as it spelled in the document.

2083

B<$value> is what you want to assigned to the field.

2084

Put all your sentences with prField early in your script. After prFile and B

2085

prDoc or prDocForm and of course before prEnd. Each sentence with prField is

2086

translated to JavaScript and merged with old JavaScript

2087

2088

See prDocForm() for an example

2089

2090

If you are going to assign a value to a field consisting of several lines, you

2091

can write like this:

2092

2093

my $string = "This is the first line \r second line \n 3:rd line";

2094

prField('fieldName', $string);

2095

2096

You can also let '$value' be a snippet of JavaScript-code that assigns something

2097

to the field. Then you have to put 'js:' first in "$value" like this:

2098

2099

my $sentence = encrypt('This will be decrypted by "unPack"(JavaScript) ');

2100

prField('Interest_9', "js: unPack('$sentence')");

2101

2102

If you refer to a JavaScript function, it has to be included with prJs first. (The

2103

JavaScript interpreter will simply not be aware of old functions in the PDF-document,

2104

when the initiation is done.)

2105

2106

2107

=head2 prFont - set current font

2108

2109

prFont ( $fontName )

2110

2111

$fontName is an "external" font name. The parameter is optional.

2112

In list context returns B<$internalName, $externalName, $oldInternalName,

2113

$oldExternalname> The first two variables refer to the current font, the two later

2114

to the font before the change. In scalar context returns b<$internalName>

2115

2116

If a font wasn't found, Helvetica will be set.

2117

These names are always recognized:

2118

2119

Courier-Oblique, Courier-BoldOblique, Helvetica, Helvetica-Bold, Helvetica-Oblique,

2120

Helvetica-BoldOblique> or abbreviated

2121

2122

(B or abbreviated B, also belong to the predefined

2123

fonts, but there is something with them that I really don't understand. You should

2124

print them first on a page, and then use other fonts, otherwise they are not displayed.)

2125

2126

You can also use a font name from an included page. It has to be spelled exactly as

2127

it is done there. Look in the file and search for "/BaseFont" and the font

2128

name. But take care, e.g. the PDFMaker which converts to PDF from different

2129

Microsoft programs, only defines exactly those letters you can see on the page. You

2130

can use the font, but perhaps some of your letters were not defined.

2131

2132

In the distribution there is an utility program, 'reuseComponent_pl', which displays

2133

included fonts in a PDF-file and prints some letters. Run it to see the name of the

2134

font and if it is worth extracting.

2135

2136

use PDF::Reuse;

2137

use strict;

2138

prFile('myFile.pdf');

2139

2140

####### One possibility #########

2141

2142

prFont('Times-Roman'); # Just setting a font

2143

prFontSize(20);

2144

prText(180, 790, "This is a heading");

2145

2146

####### Another possibility #######

2147

2148

my $font = prFont('C'); # Setting a font, getting an

2149

# internal name

2150

prAdd("BT /$font 12 Tf 25 760 Td (This is some other text)Tj ET");

2151

prEnd();

2152

2153

The example above shows you two ways of setting and using a font. One simple, and

2154

one complicated with a possibility to detail control.

2155

2156

2157

=head2 prFontSize - set current font size

2158

2159

prFontSize ( $size )

2160

2161

Returns B<$actualSize, $fontSizeBeforetheChange>. Without parameters

2162

prFontSize() sets the size to 12 points, which is default.

2163

2164

=head2 prForm - use a page from an old document as a form/background

2165

2166

Alternative 1) You put your parameters in an anonymous hash (only B is really

2167

necessary, the others get default values if not given).

2168

2169

prForm ( { file => $pdfFile, # template file

2170

page => $page, # page number (of imported template)

2171

adjust => $adjust, # try to fill the media box

2172

effect => $effect, # action to be taken

2173

tolerant => $tolerant, # continue even with an invalid form

2174

x => $x, # $x points from the left

2175

y => $y, # $y points from the bottom

2176

rotate => $degree, # rotate

2177

size => $size, # multiply everything by $size

2178

xsize => $xsize, # multiply horizontally by $xsize

2179

ysize => $ysize } ) # multiply vertically by $ysize

2180

Ex.:

2181

my $internalName = prForm ( {file => 'myFile.pdf',

2182

page => 2 } );

2183

2184

Alternative 2) You put your parameters in this order

2185

2186

prForm ( $pdfFile, $page, $adjust, $effect, $tolerant, $x, $y, $degree,

2187

$size, $xsize, $ysize )

2188

2189

2190

Anyway the function returns in list context: B<$intName, @BoundingBox,

2191

$numberOfImages>, in scalar context: B<$internalName> of the form.

2192

2193

B can be a filename, an IO::String object, a filehandle, or a scalar

2194

reference to PDF data in memory.

2195

2196

if B is excluded 1 is assumed.

2197

2198

B, could be 1, 2 or 0/nothing. If it is 1, the program tries to adjust the

2199

form to the current media box (paper size) and keeps the proportions unchanged.

2200

If it is 2, the program tries to fill as much of the media box as possible, without

2201

regards to the original proportions.

2202

If this parameter is given, "x", "y", "rotate", "size", "xsize" and "ysize"

2203

will be ignored.

2204

2205

B can have 3 values: B<'print'>, which is default, loads the page in an internal

2206

table, adds it to the document and prints it to the current page. B<'add'>, loads the

2207

page and adds it to the document. (Now you can "manually" manage the way you want to

2208

print it to different pages within the document.) B<'load'> just loads the page in an

2209

internal table. (You can now take I of a page like fonts and objects and manage

2210

them, without adding all the page to the document.)You don't get any defined

2211

internal name of the form, if you let this parameter be 'load'.

2212

2213

B can be nothing or something. If it is undefined, you will get an error if your program tries to load

2214

a page which the system cannot really handle, if it e.g. consists of many streams.

2215

If it is set to something, you have to test the first return value $internalName to

2216

know if the function was successful. Look at the program 'reuseComponent_pl' for an

2217

example of usage.

2218

2219

B where to start along the x-axis (cannot be combined with "adjust")

2220

2221

B where to start along the y-axis (cannot be combined with "adjust")

2222

2223

B A degree 0-360 to rotate the form counter-clockwise. (cannot be combined

2224

with "adjust") Often the form disappears out of the media box if degree >= 90.

2225

Then you can move it back with the x and y-parameters. If degree == 90, you can

2226

add the width of the form to x, If degree == 180 add both width and height to x

2227

and y, and if degree == 270 you can add the height to y.

2228

2229

B can also by one of 'q1', 'q2' or 'q3'. Then the system rotates the form

2230

clockwise 90, 180 or 270 degrees and tries to keep the form within the media box.

2231

2232

The rotation takes place after the form has been resized or moved.

2233

2234

Ex. To rotate from portrait (595 x 842 pt) to landscape (842 x 595 pt)

2235

2236

use PDF::Reuse;

2237

use strict;

2238

2239

prFile('New_Report.pdf');

2240

prMbox(0, 0, 842, 595);

2241

2242

prForm({file => 'cert1.pdf',

2243

rotate => 'q1' } );

2244

prEnd();

2245

2246

The same rotation can be achieved like this:

2247

2248

use PDF::Reuse;

2249

use strict;

2250

2251

prFile('New_Report.pdf');

2252

prMbox(0, 0, 842, 595);

2253

2254

prForm({file => 'cert1.pdf',

2255

rotate => 270,

2256

y => 595 } );

2257

prEnd();

2258

2259

B multiply every measure by this value (cannot be combined with "adjust")

2260

2261

B multiply horizontally by this value (cannot be combined with "adjust")

2262

2263

B multiply vertically by $ysize (cannot be combined with "adjust")

2264

2265

This function redefines a page to an "XObject" (the graphic parts), then the

2266

page can be reused and referred to as a unit. Unfortunately there is an important

2267

limitation here. "XObjects" can only have single streams. If the page consists

2268

of many streams, you should concatenate them first. Adobe Acrobat can do that.

2269

(If it is an important file, take a copy of it first. Sometimes the procedure fails.)

2270

Open the document with Acrobat. Then choose the "TouchUp Text" tool.

2271

Select a line of text somewhere. Right-click the mouse. Choose "Attributes".

2272

Change font size or anything else, and then you change it back to the old value.

2273

Save the document. You could alternatively save the file as Postscript and redistill

2274

it with the distiller or with Ghost script, but this is a little more risky. You

2275

might loose fonts or something else. Another alternative could be to use prSinglePage().

2276

2277

Alternatively, GhostScript can be used to convert multi-stream PDFs into

2278

single-stream format compatible with prForm:

2279

2280

gs -sDEVICE=pdfwrite -dCompatibilityLevel=1.4 -dPDFSETTINGS=/default \

2281

-dNOPAUSE -dQUIET -dBATCH -dDetectDuplicateImages \

2282

-dCompressFonts=true -r150 -sOutputFile=output.pdf input.pdf

2283

2284

2285

use PDF::Reuse;

2286

use strict;

2287

2288

prFile('myFile.pdf');

2289

prForm('best.pdf'); # Takes page No 1

2290

prText(75, 790, 'Dear Mr Gates');

2291

# ...

2292

prPage();

2293

prMbox(0, 0, 900, 960);

2294

my @vec = prForm( { file => 'EUSA.pdf',

2295

adjust => 1 } );

2296

prPage();

2297

prMbox();

2298

prText(35, 760, 'This is the final page');

2299

2300

# More text ..

2301

2302

#################################################################

2303

# We want to put a miniature of EUSA.pdf, 35 points from the left

2304

# 85 points up, and in the format 250 X 200 points

2305

#################################################################

2306

2307

my $xScale = 250 / ($vec[3] - $vec[1]);

2308

my $yScale = 200 / ($vec[4] - $vec[2]);

2309

2310

prForm ({ file => 'EUSA.pdf',

2311

xsize => $xScale,

2312

ysize => $yScale,

2313

x => 35,

2314

y => 85 });

2315

2316

prEnd();

2317

2318

The first prForm(), in the code, is a simple and "normal" way of using the

2319

the function. The second time it is used, the size of the imported page is

2320

changed. It is adjusted to the media box which is current at that moment.

2321

Also data about the form is taken, so you can control more in detail how it

2322

will be displayed.

2323

2324

=head2 prGetLogBuffer - get the log buffer.

2325

2326

prGetLogBuffer ()

2327

2328

returns a B<$buffer> of the log of the current page. (It could be used

2329

e.g. to calculate a MD5-digest of what has been registered that far, instead of

2330

accumulating the single values) A log has to be active, see prLogDir() below

2331

2332

Look at "Using the template" and "Restoring a document from the log" in the

2333

tutorial for examples of usage.

2334

2335

=head2 prGraphState - define a graphic state parameter dictionary

2336

2337

prGraphState ( $string )

2338

2339

This is a "low level" function. Returns B<$internalName>. The B<$string> has to

2340

be a complete dictionary with initial "<<" and terminating ">>". No syntactical

2341

checks are made. Perhaps you will never have to use this function.

2342

2343

use PDF::Reuse;

2344

use strict;

2345

2346

prFile('myFile.pdf');

2347

2348

###################################################

2349

# Draw a triangle with Gs0 (automatically defined)

2350

###################################################

2351

2352

my $str = "q\n";

2353

$str .= "/Gs0 gs\n";

2354

$str .= "150 700 m\n";

2355

$str .= "225 800 l\n";

2356

$str .= "300 700 l\n";

2357

$str .= "150 700 l\n";

2358

$str .= "S\n";

2359

$str .= "Q\n";

2360

prAdd($str);

2361

2362

########################################################

2363

# Define a new graph. state param. dic. and draw a new

2364

# triangle further down

2365

########################################################

2366

2367

$str = '<

2368

. '/LW 15/LJ 1/ML 1>>';

2369

my $gState = prGraphState($str);

2370

$str = "q\n";

2371

$str .= "/$gState gs\n";

2372

$str .= "150 500 m\n";

2373

$str .= "225 600 l\n";

2374

$str .= "300 500 l\n";

2375

$str .= "150 500 l\n";

2376

$str .= "S\n";

2377

$str .= "Q\n";

2378

prAdd($str);

2379

2380

prEnd();

2381

2382

2383

=head2 prImage - reuse an image from an old PDF document

2384

2385

Alternative 1) You put your parameters in an anonymous hash (only B is really

2386

necessary, the others get default values if not given).

2387

2388

prImage( { file => $pdfFile, # template file

2389

page => $page, # page number

2390

imageNo => $imageNo # image number

2391

adjust => $adjust, # try to fill the media box

2392

effect => $effect, # action to be taken

2393

x => $x, # $x points from the left

2394

y => $y, # $y points from the bottom

2395

rotate => $degree, # rotate

2396

size => $size, # multiply everything by $size

2397

xsize => $xsize, # multiply horizontally by $xsize

2398

ysize => $ysize } ) # multiply vertically by $ysize

2399

Ex.:

2400

prImage( { file => 'myFile.pdf',

2401

page => 10,

2402

imageNo => 2 } );

2403

2404

Alternative 2) You put your parameters in this order

2405

2406

prImage ( $pdfFile, [$page, $imageNo, $effect, $adjust, $x, $y, $degree,

2407

$size, $xsize, $ysize] )

2408

2409

Returns in scalar context B<$internalName> As a list B<$internalName, $width,

2410

$height>

2411

2412

Assumes that $pageNo and $imageNo are 1, if not specified. If $effect is given and

2413

anything else then 'print', the image will be defined in the document,

2414

but not shown at this moment.

2415

2416

For all other parameters, look at prForm().

2417

2418

use PDF::Reuse;

2419

use strict;

2420

2421

prFile('myFile.pdf');

2422

my @vec = prImage({ file => 'best.pdf',

2423

x => 10,

2424

y => 400,

2425

xsize => 0.9,

2426

ysize => 0.8 } );

2427

prText(35, 760, 'This is some text');

2428

# ...

2429

prPage();

2430

my @vec2 = prImage( { file => 'destiny.pdf',

2431

page => 1,

2432

imageNo => 1,

2433

effect => 'add' } );

2434

prText(25, 760, "There shouldn't be any image on this page");

2435

prPage();

2436

########################################################

2437

# Now we make both images so that they could fit into

2438

# a box 300 X 300 points, and they are displayed

2439

########################################################

2440

2441

prText(25, 800, 'This is the first image :');

2442

2443

my $xScale = 300 / $vec[1];

2444

my $yScale = 300 / $vec[2];

2445

if ($xScale < $yScale)

2446

{ $yScale = $xScale;

2447

}

2448

else

2449

{ $xScale = $yScale;

2450

}

2451

prImage({ file => 'best.pdf',

2452

x => 25,

2453

y => 450,

2454

xsize => $xScale,

2455

ysize => $yScale} );

2456

2457

prText(25, 400, 'This is the second image :');

2458

2459

$xScale = 300 / $vec2[1];

2460

$yScale = 300 / $vec2[2];

2461

if ($xScale < $yScale)

2462

{ $yScale = $xScale;

2463

}

2464

else

2465

{ $xScale = $yScale;

2466

}

2467

prImage({ file => 'destiny.pdf',

2468

x => 25,

2469

y => 25,

2470

xsize => $xScale,

2471

ysize => $yScale} );

2472

2473

prEnd();

2474

2475

On the first page an image is displayed in a simple way. While the second page

2476

is processed, prImage(), loads an image, but it is not shown here. On the 3:rd

2477

page, the two images are scaled and shown.

2478

2479

In the distribution there is an utility program, 'reuseComponent_pl', which displays

2480

included images in a PDF-file and their "names".

2481

2482

=head2 prInit - add JavaScript to be executed at initiation

2483

2484

prInit ( $string, $duplicateCode )

2485

2486

B<$string> can be any JavaScript code, but you can only refer to functions included

2487

with prJs. The JavaScript interpreter will not know other functions in the document.

2488

Often you can add new things, but you can't remove or change interactive fields,

2489

because the interpreter hasn't come that far, when initiation is done.

2490

2491

B<$duplicateCode> is undefined or anything. It duplicates the JavaScript code

2492

which has been used at initiation, so you can look at it from within Acrobat and

2493

debug it. It makes the document bigger. This parameter is B.

2494

2495

use PDF::Reuse;

2496

use strict;

2497

2498

prFile('myFile.pdf');

2499

prInit('app.alert("This is displayed when opening the document");');

2500

2501

prEnd();

2502

2503

2504

Remark: Avoid to use "return" in the code you use at initiation. If your user has

2505

downloaded a page with Web Capture, and after that opens a PDF-document where a

2506

JavaScript is run at initiation and that JavaScript contains a return-statement,

2507

a bug occurs. The JavaScript interpreter "exits" instead of returning, the execution

2508

of the JavaScript might finish to early. This is a bug in Acrobat/Reader 5.

2509

2510

2511

=head2 prInitVars - initiate global variables and internal tables

2512

2513

prInitVars(1)

2514

2515

If you run programs with PDF::Reuse as persistent procedures, you probably need to

2516

initiate global variables. If you have '1' or anything as parameter, internal tables for forms, images, fonts

2517

and interactive functions are B initiated. The module "learns" offset and sizes of

2518

used objects, and can process them faster, but at the same time the size of the

2519

program grows.

2520

2521

use PDF::Reuse;

2522

use strict;

2523

prInitVars(); # To initiate ALL global variables and tables

2524

# prInitVars(1); # To make it faster, but more memory consuming

2525

2526

$| = 1;

2527

print STDOUT "Content-Type: application/pdf \n\n";

2528

2529

prFile(); # To send the document uncatalogued to STDOUT

2530

2531

prForm('best.pdf');

2532

prText(25, 790, 'Dear Mr. Anders Persson');

2533

# ...

2534

prEnd();

2535

2536

If you call this function without parameters all global variables, including the

2537

internal tables, are initiated.

2538

2539

2540

=head2 prAltJpeg - import a low-res jpeg-image for display and a high-res jpeg-image for printing

2541

2542

prAltJpeg ( $imageData, $width, $height, $format, $altImageData, $altWidth, $altHeight, $altFormat )

2543

2544

B<$imageData> contains 1 single jpeg-image. B<$width> and B<$height>

2545

also have to be specified. B<$format> indicates the format the image

2546

data takes: 0 for file, 1 for binary string. B<$altImageData> etc.

2547

follows the same foramt. Returns the B<$internalName>

2548

2549

use PDF::Reuse;

2550

use Image::Info qw(image_info dim);

2551

use strict;

2552

2553

my $file = 'myImage.jpg';

2554

my $info = image_info($file);

2555

my ($width, $height) = dim($info); # Get the dimensions

2556

my $colortype = $info->{color_type}; # get color space

2557

2558

my $alt_file = 'myImage.jpg';

2559

my $alt_info = image_info($alt_file);

2560

my ($alt_width, $alt_height) = dim($alt_info);

2561

2562

prFile('myFile.pdf');

2563

my $intName = prAltJpeg("$file", # Define the image

2564

$width, # in the document

2565

$height,

2566

2567

"$alt_file",

2568

$alt_width,

2569

$alt_height,

2570

0);

2571

2572

my $str = "q\n";

2573

$str .= "$width 0 0 $height 10 10 cm\n";

2574

$str .= "/$intName Do\n";

2575

$str .= "Q\n";

2576

prAdd($str);

2577

prEnd();

2578

2579

2580

=head2 prJpeg - import a jpeg-image

2581

2582

prJpeg ( $imageData, $width, $height, $format )

2583

2584

B<$imageData> contains 1 single jpeg-image. B<$width> and B<$height>

2585

also have to be specified. B<$format> indicates the format the image

2586

data takes: 0 for file, 1 for binary string. Returns the B<$internalName>

2587

2588

use PDF::Reuse;

2589

use Image::Info qw(image_info dim);

2590

use strict;

2591

2592

my $file = 'myImage.jpg';

2593

my $info = image_info($file);

2594

my ($width, $height) = dim($info); # Get the dimensions

2595

2596

prFile('myFile.pdf');

2597

my $intName = prJpeg("$file", # Define the image

2598

$width, # in the document

2599

$height,

2600

0);

2601

2602

my $str = "q\n";

2603

$str .= "$width 0 0 $height 10 10 cm\n";

2604

$str .= "/$intName Do\n";

2605

$str .= "Q\n";

2606

prAdd($str);

2607

prEnd();

2608

2609

This is a little like an extra or reserve routine to add images to the document.

2610

The most simple way is to use prImage()

2611

2612

=head2 prJs - add JavaScript

2613

2614

prJs ( $string|$fileName )

2615

2616

To add JavaScript to your new document. B<$string> has to consist only of

2617

JavaScript functions: function a (..){ ... } function b (..) { ...} and so on

2618

If B<$string> doesn't contain '{', B<$string> is interpreted as a filename.

2619

In that case the file has to consist only of JavaScript functions.

2620

2621

2622

2623

=head2 prLink - add a hyper link

2624

2625

prLink( { page => $pageNo, # Starting with 1 !

2626

x => $x,

2627

y => $y,

2628

width => $width,

2629

height => $height,

2630

URI => $URI } );

2631

2632

You can also call prLink like this:

2633

2634

prLink($page, $x, $y, $width, $height, $URI);

2635

2636

You have to put prLink B

2637

is created>. The links are created at the page-breaks. If the page is already

2638

created, no new link will be inserted.

2639

2640

Here is an example where the links of a 4 page document are preserved, and a link is

2641

added at the end of the document. We assume that there is some suitable text at that

2642

place (x = 400, y = 350):

2643

2644

use strict;

2645

use PDF::Reuse;

2646

2647

prFile('test.pdf');

2648

2649

prLink( {page => 4,

2650

x => 400,

2651

y => 350,

2652

width => 105,

2653

height => 15,

2654

URI => 'http://www.purelyInvented.com/info.html' } );

2655

2656

prDoc('fourPages.pdf');

2657

2658

prEnd();

2659

2660

( If you are creating each page of a document separately, you can also use 'hyperLink'

2661

from PDF::Reuse::Util. Then you get an external text in Helvetica-Oblique, underlined

2662

and in blue.

2663

2664

use strict;

2665

use PDF::Reuse;

2666

use PDF::Reuse::Util;

2667

2668

prFile('test.pdf');

2669

prForm('template.pdf', 5);

2670

my ($from, $pos) = prText(25, 700, 'To get more information ');

2671

2672

$pos = hyperLink( $pos, 700, 'Press this link',

2673

'http://www.purelyInvented.com/info.html' );

2674

($from, $pos) = prText( $pos, 700, ' And get connected');

2675

prEnd();

2676

2677

'hyperLink' has a few parameters: $x, $y, $textToBeShown, $hyperLink and

2678

$fontSize (not shown in the example). It returns current x-position. )

2679

2680

=head2 prLog - add a string to the log

2681

2682

prLog ( $string )

2683

2684

Adds whatever you want to the current log (a reference No, a commentary, a tag ?)

2685

A log has to be active see prLogDir()

2686

2687

Look at "Using the template" and "Restoring the document from the log" in

2688

the tutorial for an example.

2689

2690

=head2 prLogDir - set directory for the log

2691

2692

prLogDir ( $directory )

2693

2694

Sets a directory for the logs and activates the logging.

2695

A little log file is created for each PDF-file. Normally it should be much, much

2696

more compact then the PDF-file, and it should be possible to restore or verify

2697

a document with the help of it. (Of course you could compress or store the logs in a

2698

database to save even more space.)

2699

2700

use PDF::Reuse;

2701

use strict;

2702

2703

prDocDir('C:/temp/doc');

2704

prLogDir('C:/run');

2705

2706

prFile('myFile.pdf');

2707

prForm('best.pdf');

2708

prText(25, 790, 'Dear Mr. Anders Persson');

2709

# ...

2710

prEnd();

2711

2712

In this example a log file with the name 'myFile.pdf.dat' is created in the

2713

directory 'C:\run'. If that directory doesn't exist, the system tries to create it.

2714

(But, just as mkdir does, it only creates the last level in a directory tree.)

2715

2716

=head2 prMbox - define the format (MediaBox) for a new page.

2717

2718

prMbox ( $lowerLeftX, $lowerLeftY, $upperRightX, $upperRightY )

2719

2720

If the function or the parameters are missing, they are set to 0, 0, 595, 842 points respectively.

2721

Only for new pages. Pages created with prDoc and prSinglePage keep their media boxes unchanged.

2722

2723

See prForm() for an example.

2724

2725

2726

=head2 prPage - create/insert a page

2727

2728

prPage ($noLog)

2729

2730

Don't use the optional parameter, it is only used internally, not to clutter the log,

2731

when automatic page breaks are made.

2732

2733

2734

See prForm() for an example.

2735

2736

=head2 prSinglePage - take single pages, one by one, from an old document

2737

2738

prSinglePage($file, $pageNumber)

2739

2740

$pageNumber is optional. If not given, next page is assumed

2741

Returns number of remaining pages.

2742

This function is a variant of prDoc for single pages, with the addition that it

2743

has a counter of last page read, and total number of pages of the old document,

2744

so it can be used to loop through a document.

2745

2746

2747

To add a form, image and page number to each page of a document

2748

(The document Battery.pdf is cropped so each page is fairly small) You could also have

2749

used prDoc, but only if you knew in advance the number of pages of the old document

2750

2751

use PDF::Reuse;

2752

use PDF::Reuse::Util;

2753

use strict;

2754

2755

prFile('test.pdf');

2756

2757

my $pageNumber = 0;

2758

my $left = 1; # Every valid PDF-document has at least 1 page,

2759

# so that can be assumed

2760

2761

while ($left)

2762

{ $pageNumber++;

2763

prForm( { file =>'Words.pdf',

2764

page => 5,

2765

x => 150,

2766

y => 150} );

2767

2768

prImage( { file =>'Media.pdf',

2769

page => 6,

2770

imageNo => 1,

2771

x => 450,

2772

y => 450 } );

2773

blackText();

2774

prText( 360, 250, $pageNumber);

2775

$left = prSinglePage('Battery.pdf');

2776

}

2777

2778

prEnd;

2779

2780

prSinglePage creates a new page from an old document and adds new content (to the array of

2781

streams of that page). Most often you can add new contents to the page like the example above,

2782

and it works fine, but sometimes you get surprises. There can e.g. be instructions in the earlier

2783

contents to make filling color white, and then you will probably not see added new text. That

2784

is why PDF::Reuse::Util::blackText() is used in the example. There can be other instructions

2785

like moving or rotating the user space. Also new contents can end up outside the crop-box.

2786

Of course all new programs should be tested. If prSinglePage can't be used, try to use prForm

2787

followed by prPage instead.

2788

2789

2790

=head2 prStrWidth - calculate the string width

2791

2792

prStrWidth($string, $font, $fontSize)

2793

2794

Returns string width in points.

2795

Should be used in conjunction with one of these predefined fonts of Acrobat/Reader:

2796

Times-Roman, Times-Bold, Times-Italic, Times-BoldItalic, Courier, Courier-Bold, Courier-Oblique,

2797

Courier-BoldOblique, Helvetica, Helvetica-Bold, Helvetica-Oblique,

2798

Helvetica-BoldOblique or with a TrueType font embedded with prTTFont. If some other font is

2799

given, Helvetica is used, and the returned value will at the best be approximate.

2800

2801

=head2 prText - add a text-string

2802

2803

prText ( $x, $y, $string, $align, $rotation )

2804

2805

Puts B<$string> at position B<$x, $y>

2806

Returns 1 in scalar context. Returns ($xFrom, $xTo) in list context. $xTo will not

2807

be defined together with a rotation. prStrWidth() is used to calculate the length of the

2808

strings, so only the predefined fonts together with Acrobat/Reader, or embedded TrueType

2809

fonts will give reliable values for $xTo.

2810

2811

$align can be 'left' (= default), 'center' or 'right'. The parameter is optional.

2812

2813

$rotation can be a degree 0 - 360, 'q1', 'q2' or 'q3'. Also optional.

2814

2815

Current font and font size are used. (If you use prAdd() before this function,

2816

many other things could also influence the text.)

2817

2818

use strict;

2819

use PDF::Reuse;

2820

2821

prFile('test.pdf');

2822

2823

#####################################

2824

# Use a "curser" ($pos) along a line

2825

#####################################

2826

2827

my ($from, $pos) = prText(25, 800, 'First write this. ');

2828

($from, $pos) = prText($pos, 800, 'Then write this. ');

2829

prText($pos, 800, 'Finally write this.');

2830

2831

#####################################

2832

# Right adjust and center sentences

2833

#####################################

2834

2835

prText( 200, 750, 'A short sentence', 'right');

2836

prText( 200, 735, 'This is a longer sentence', 'right');

2837

prText( 200, 720, 'A word', 'right');

2838

2839

prText( 200, 705, 'Centered around a point 200 points from the left', 'center');

2840

prText( 200, 690, 'The same center', 'center');

2841

prText( 200, 675, '->.<-', 'center');

2842

2843

############

2844

# Rotation

2845

############

2846

2847

prText( 200, 550, ' Rotate 0 degrees','', 0);

2848

prText( 200, 550, ' Rotate 60 degrees','', 60);

2849

prText( 200, 550, ' Rotate 120 degrees','', 120);

2850

prText( 200, 550, ' Rotate 180 degrees','', 180);

2851

prText( 200, 550, ' Rotate 240 degrees','', 240);

2852

prText( 200, 550, ' Rotate 300 degrees','', 300);

2853

2854

prText( 400, 430, 'Rotate 90 degrees clock-wise','','q1');

2855

prText( 400, 430, 'Rotate 180 degrees clock-wise','', 'q2');

2856

prText( 400, 430, 'Rotate 270 degrees clock-wise','', 'q3');

2857

2858

##########################

2859

# Rotate and right adjust

2860

##########################

2861

2862

prText( 200, 230, 'Rotate 90 degrees clock-wise ra->','right','q1');

2863

prText( 200, 230, 'Rotate 180 degrees clock-wise ra->','right', 'q2');

2864

prText( 200, 230, 'Rotate 270 degrees clock-wise ra->','right', 'q3');

2865

2866

prEnd();

2867

2868

=head2 prTTFont - select and embed a TrueType font

2869

2870

prTTFont ( "/path/to/font/file.ttf" )

2871

2872

This function is equivalent to C except that rather than restricting

2873

you to the list of core built-in fonts, it allows you to select an external

2874

TrueType font file and have it embedded in your PDF document. Using TrueType

2875

fonts also enables the C function to accept UTF-8 strings, which allows

2876

you to use characters outside the Mac-Roman/Win-ANSI character sets used by the

2877

built-in fonts.

2878

2879

You can specify the same font path multiple times in one document and only one

2880

copy will be embedded. Alternatively, C returns an identifier which

2881

can be used to select the same font again:

2882

2883

my $arial = prTTFont('/path/to/Arial.ttf');

2884

prFontSize(20);

2885

prText(20, 700, 'Some text in Arial');

2886

2887

# ... later ...

2888

2889

prPage();

2890

prTTFont($arial);

2891

prFontSize(12);

2892

prText(20, 700, 'Some more text in Arial');

2893

2894

# to pass a UTF8 string to prText

2895

2896

prText(20, 675, "T\x{113}n\x{101} koutou"); # T?n? Koutou

2897

2898

In list context this function returns C<$internalName>, C<$externalName>,

2899

C<$oldInternalName>, C<$oldExternalname>. The first two variables refer to the

2900

current font, the last two refer to the font before the change. In scalar

2901

context only C<$internalName> is returned.

2902

2903

Note: To use this function, you must have the L and L

2904

modules installed.

2905

2906

2907

=head1 INTERNAL OR DEPRECATED FUNCTIONS

2908

2909

=over 2

2910

2911

=item prBar - define and paint bars for bar fonts

2912

2913

prBar ($x, $y, $string)

2914

2915

Prints a bar font pattern at the current page.

2916

Returns $internalName for the font.

2917

$x and $y are coordinates in points and $string should consist of the characters

2918

'0', '1' and '2' (or 'G'). '0' is a white bar, '1' is a dark bar. '2' and 'G' are

2919

dark, slightly longer bars, guard bars.

2920

You can use e.g. GD::Barcode or one module in that group to calculate the bar code

2921

pattern. prBar "translates" the pattern to white and black bars.

2922

2923

use PDF::Reuse;

2924

use GD::Barcode::Code39;

2925

use strict;

2926

2927

prFile('myFile.pdf');

2928

my $oGdB = GD::Barcode::Code39->new('JOHN DOE');

2929

my $sPtn = $oGdB->barcode();

2930

prBar(100, 600, $sPtn);

2931

prEnd();

2932

2933

Internally the module uses a font for the bars, so you might want to change the font size before calling

2934

this function. In that case, use prFontSize() .

2935

If you call this function without arguments it defines the bar font but does

2936

not write anything to the current page.

2937

2938

2939

Look at that module!

2940

2941

=item prCid - define time stamp/check id

2942

2943

prCid ( $timeStamp )

2944

2945

An internal function. Don't bother about it. It is used in automatic

2946

routines when you want to restore a document. It gives modification time of

2947

the next PDF-file or JavaScript.

2948

See "Restoring a document from the log" in the tutorial for more about the

2949

time stamp

2950

2951

2952

2953

=item prId - define id-string of a PDF document

2954

2955

prId ( $string )

2956

2957

An internal function. Don't bother about it. It is used e.g. when a document is

2958

restored and an id has to be set, not calculated.

2959

2960

=item prIdType - define id-type

2961

2962

prIdType ( $string )

2963

2964

An internal function. Avoid using it. B<$string> could be "Rep" for replace or

2965

"None" to avoid calculating an id.

2966

2967

Normally you don't use this function. Then an id is calculated with the help of

2968

Digest::MD5::md5_hex and some data from the run.

2969

2970

2971

=item prTouchUp - make changes and reuse more difficult

2972

2973

prTouchUp (1);

2974

2975

By default and after you have issued prTouchUp(1), you can change the document

2976

with the TouchUp tool from within Acrobat.

2977

If you want to switch off this possibility, you use prTouchUp() without any

2978

parameter. Then the user shouldn't be able to change anything graphic by mistake.

2979

He has to do something premeditated and perhaps with a little effort.

2980

He could still save it as Postscript and redistill, or he could remove or add single pages.

2981

(Here is a strong reason why the log files, and perhaps also check sums, are needed.

2982

It would be very difficult to forge a document unless the forger also has access to your

2983

computer and knows how the check sums are calculated.)

2984

2985

B It creates an

2986

extra level within the PDF-documents . Use this function for your final documents.

2987

2988

See "Using the template" in the tutorial for an example.

2989

2990

This function works for pages created with prPage, but mot with prDoc and prSinglePage,

2991

So it is more or less deprecated as these function have developed.

2992

2993

(To encrypt your documents: use the batch utility within Acrobat)

2994

2995

2996

=item prVers - check version of log and program

2997

2998

prVers ( $versionNo )

2999

3000

To check version of this module in case a document has to be

3001

restored.

3002

3003

=back

3004

3005

=head1 SEE ALSO

3006

3007

PDF::Reuse::Tutorial

3008

PDF::Reuse::Barcode

3009

PDF::Reuse::OverlayChart

3010

3011

To program with PDF-operators, look at "The PDF-reference Manual" which probably

3012

is possible to download from http://partners.adobe.com/asn/tech/pdf/specifications.jsp

3013

Look especially at chapter 4 and 5, Graphics and Text, and the Operator summary.

3014

3015

Technical Note # 5186 contains the "Acrobat JavaScript Object Specification". I

3016

downloaded it from http://partners.adobe.com/asn/developer/technotes/acrobatpdf.html

3017

3018

If you are serious about producing PDF-files, you probably need Adobe Acrobat sooner

3019

or later. It has a price tag. Other good programs are GhostScript and GSview.

3020

I got them via http://www.cs.wisc.edu/~ghost/index.html Sometimes they can replace Acrobat.

3021

A nice little detail is e.g. that GSview shows the x- and y-coordinates better then Acrobat. If you need to convert HTML-files to PDF, HTMLDOC is a possible tool. Download it from

3022

http://www.easysw.com . A simple tool for vector graphics is Mayura Draw 2.04, download

3023

it from http://www.mayura.com. It is free. I have used it to produce the graphic

3024

OO-code in the tutorial. It produces postscript which the Acrobat Distiller (you get it together with Acrobat)

3025

or Ghostscript can convert to PDF.(The commercial product, Mayura Draw 4.01 or something

3026

higher can produce PDF-files straight away)

3027

3028

If you want to import jpeg-images, you might need

3029

3030

Image::Info

3031

3032

To get definitions for e.g. colors, take them from

3033

3034

PDF::API2::Util

3035

3036

=head1 LIMITATIONS

3037

3038

Meta data, info and many other features of the PDF-format have not been

3039

implemented in this module.

3040

3041

Many things can be added afterwards, after creating the files. If you e.g. need

3042

files to be encrypted, you can use a standard batch routine within Adobe Acrobat.

3043

3044

=head1 THANKS TO

3045

3046

Martin Langhoff, Matisse Enzer, Yunliang Yu and others who have contributed with code, suggestions and error

3047

reports.

3048

3049

Grant McLean has implemented font embedding by grafting Font::TTF and

3050

Text::PDF::TTFont0 onto the PDF::Reuse API. He has written the embedded packages PDF::Reuse::DocProxy

3051

and PDF::Reuse::TTFont.

3052

3053

The functionality of prDoc and prSinglePage to include new contents was developed for a

3054

specific task with support from the Electoral Enrolment Centre, Wellington, New Zealand

3055

3056

=head1 MAILING LIST

3057

3058

http://groups.google.com/group/PDF-Reuse

3059

3060

=head1 AUTHOR

3061

3062

Lars Lundberg larslund@cpan.org

3063

Chris Nighswonger cnighs@cpan.org

3064

3065

=head1 COPYRIGHT

3066

3067

3068

3069

3070

3071

This program is free software; you can redistribute it and/or

3072

modify it under the same terms as Perl itself.

3073

3074

=head1 DISCLAIMER

3075

3076

You get this module free as it is, but nothing is guaranteed to work, whatever

3077

implicitly or explicitly stated in this document, and everything you do,

3078

you do at your own risk - I will not take responsibility

3079

for any damage, loss of money and/or health that may arise from the use of this module.

3080

3081

=cut

3082

3083

sub prSinglePage

3084

{ my $infil = shift;

3085

my $pageNumber = shift;

3086

3087

if (! defined $pageNumber)

3088

{ $behandlad{$infil}->{pageNumber} = 0

3089

unless (defined $behandlad{$infil}->{pageNumber});

3090

$pageNumber = $behandlad{$infil}->{pageNumber} + 1;

3091

}

3092

3093

my ($sida, $Names, $AARoot, $AcroForm) = analysera($infil, $pageNumber, $pageNumber, 1);

3094

if (($Names) || ($AARoot) || ($AcroForm))

3095

{ $NamesSaved = $Names;

3096

$AARootSaved = $AARoot;

3097

$AcroFormSaved = $AcroForm;

3098

$interActive = 1;

3099

}

3100

if (defined $sida)

3101

{ $behandlad{$infil}->{pageNumber} = $pageNumber;

3102

}

3103

if ($runfil)

3104

{ $infil = prep($infil);

3105

$log .= "prSinglePage~$infil~$pageNumber\n";

3106

}

3107

if (! $pos)

3108

{ errLog("No output file, you have to call prFile first");

3109

}

3110

return $sida;

3111

3112

}

3113

3114

3115

3116

sub prLink

3117

{ my %link;

3118

my $param = shift;

3119

if (ref($param) eq 'HASH')

3120

{ $link{page} = $param->{'page'} || -1;

3121

$link{x} = $param->{'x'} || 100;

3122

$link{y} = $param->{'y'} || 100;

3123

$link{width} = $param->{width} || 75;

3124

$link{height} = $param->{height} || 15;

3125

$link{v} = $param->{URI};

3126

$link{s} = $param->{s} || "URI";

3127

}

3128

else

3129

{ $link{page} = $param || -1;

3130

$link{x} = shift || 100;

3131

$link{y} = shift || 100;

3132

$link{width} = shift || 75;

3133

$link{height} = shift || 15;

3134

$link{v} = shift;

3135

$link{s} = shift || "URI";

3136

}

3137

3138

if (! $pos)

3139

{ errLog("No output file, you have to call prFile first");

3140

}

3141

3142

if ($runfil)

3143

{ $log .= "Link~$link{page}~$link{x}~$link{y}~$link{width}~"

3144

. "$link{height}~$link{v}~$link{s}\n";

3145

}

3146

3147

if ($link{v})

3148

{ push @{$links{$link{page}}}, \%link;

3149

}

3150

3151

}

3152

3153

sub mergeLinks

3154

{ my $tSida = $sida + 1;

3155

my $rad;

3156

my ($linkObject, $linkObjectNo);

3157

for my $link (@{$links{'-1'}}, @{$links{$tSida}} )

3158

{ my $x2 = $link->{x} + $link->{width};

3159

my $y2 = $link->{y} + $link->{height};

3160

if (exists $links{$link->{v}})

3161

{ $linkObjectNo = $links{$link->{v}};

3162

}

3163

else

3164

{ $objNr++;

3165

$objekt[$objNr] = $pos;

3166

my $v_n;

3167

my $v_v = '('.$link->{v}.')';

3168

if ($link->{s} eq 'GoTo')

3169

{ $v_n = "D";

3170

}

3171

elsif ($link->{s} eq 'GoToA')

3172

{ $link->{s} = 'GoTo';

3173

$v_n = 'D';

3174

$v_v = $link->{v};

3175

}

3176

elsif ($link->{s} eq 'Launch') {$v_n = 'F';}

3177

elsif ($link->{s} eq 'SubmitForm') {$v_n = 'F';}

3178

elsif ($link->{s} eq 'Named')

3179

{ $v_n = 'N';

3180

$v_v = $link->{v};

3181

}

3182

elsif ($link->{s} eq 'JavaScript') {$v_n = "JS";}

3183

else

3184

{ $v_n = $link->{s};

3185

}

3186

$rad = "$objNr 0 obj<{s}/$v_n$v_v>>endobj\n";

3187

$linkObjectNo = $objNr;

3188

$links{$link->{v}} = $objNr;

3189

$pos += syswrite UTFIL, $rad;

3190

}

3191

$rad = "/Subtype/Link/Rect[$link->{x} $link->{y} "

3192

. "$x2 $y2]/A $linkObjectNo 0 R/Border[0 0 0]";

3193

if (exists $links{$rad})

3194

{ push @annots, $links{$rad};

3195

}

3196

else

3197

{ $objNr++;

3198

$objekt[$objNr] = $pos;

3199

$links{$rad} = $objNr;

3200

$rad = "$objNr 0 obj<<$rad>>endobj\n";

3201

$pos += syswrite UTFIL, $rad;

3202

push @annots, $objNr;

3203

}

3204

}

3205

@{$links{'-1'}} = ();

3206

@{$links{$tSida}} = ();

3207

$objNr++;

3208

$objekt[$objNr] = $pos;

3209

$rad = "$objNr 0 obj[\n";

3210

for (@annots)

3211

{ $rad .= "$_ 0 R\n";

3212

}

3213

$rad .= "]endobj\n";

3214

$pos += syswrite UTFIL, $rad;

3215

@annots = ();

3216

return $objNr;

3217

}

3218

3219

3220

sub prBookmark

3221

{ my $param = shift;

3222

if (! ref($param))

3223

{ $param = eval ($param);

3224

}

3225

if (! ref($param))

3226

{ return undef;

3227

}

3228

if (! $pos)

3229

{ errLog("No output file, you have to call prFile first");

3230

}

3231

if (ref($param) eq 'HASH')

3232

{ push @bookmarks, $param;

3233

}

3234

else

3235

{ push @bookmarks, (@$param);

3236

}

3237

if ($runfil)

3238

{ local $Data::Dumper::Indent = 0;

3239

$param = Dumper($param);

3240

$param =~ s/^\$VAR1 = //;

3241

$param = prep($param);

3242

$log .= "Bookmark~$param\n";

3243

}

3244

return 1;

3245

}

3246

3247

sub ordnaBookmarks

3248

{ my ($first, $last, $me, $entry, $rad);

3249

$totalCount = 0;

3250

if (defined $objekt[$objNr])

3251

{ $objNr++;

3252

}

3253

$me = $objNr;

3254

3255

my $number = $#bookmarks;

3256

for (my $i = 0; $i <= $number ; $i++)

3257

{ my %hash = %{$bookmarks[$i]};

3258

$objNr++;

3259

$hash{'this'} = $objNr;

3260

if ($i == 0)

3261

{ $first = $objNr;

3262

}

3263

if ($i == $number)

3264

{ $last = $objNr;

3265

}

3266

if ($i < $number)

3267

{ $hash{'next'} = $objNr + 1;

3268

}

3269

if ($i > 0)

3270

{ $hash{'previous'} = $objNr - 1;

3271

}

3272

$bookmarks[$i] = \%hash;

3273

}

3274

3275

for $entry (@bookmarks)

3276

{ my %hash = %{$entry};

3277

descend ($me, %hash);

3278

}

3279

3280

$objekt[$me] = $pos;

3281

3282

$rad = "$me 0 obj<<";

3283

$rad .= "/Type/Outlines";

3284

$rad .= "/Count $totalCount";

3285

if (defined $first)

3286

{ $rad .= "/First $first 0 R";

3287

}

3288

if (defined $last)

3289

{ $rad .= "/Last $last 0 R";

3290

}

3291

$rad .= ">>endobj\n";

3292

$pos += syswrite UTFIL, $rad;

3293

3294

return $me;

3295

3296

}

3297

3298

sub descend

3299

{ my ($parent, %entry) = @_;

3300

my ($first, $last, $count, $me, $rad, $jsObj);

3301

if (! exists $entry{'close'})

3302

{ $totalCount++; }

3303

$count = $totalCount;

3304

$me = $entry{'this'};

3305

if (exists $entry{'kids'})

3306

{ if (ref($entry{'kids'}) eq 'ARRAY')

3307

{ my @array = @{$entry{'kids'}};

3308

my $number = $#array;

3309

for (my $i = 0; $i <= $number ; $i++)

3310

{ $objNr++;

3311

$array[$i]->{'this'} = $objNr;

3312

if ($i == 0)

3313

{ $first = $objNr;

3314

}

3315

if ($i == $number)

3316

{ $last = $objNr;

3317

}

3318

3319

if ($i < $number)

3320

{ $array[$i]->{'next'} = $objNr + 1;

3321

}

3322

if ($i > 0)

3323

{ $array[$i]->{'previous'} = $objNr - 1;

3324

}

3325

if (exists $entry{'close'})

3326

{ $array[$i]->{'close'} = 1;

3327

}

3328

}

3329

3330

for my $element (@array)

3331

{ descend($me, %{$element})

3332

}

3333

}

3334

else # a hash

3335

{ my %hash = %{$entry{'kids'}};

3336

$objNr++;

3337

$hash{'this'} = $objNr;

3338

$first = $objNr;

3339

$last = $objNr;

3340

descend($me, %hash)

3341

}

3342

}

3343

3344

3345

$objekt[$me] = $pos;

3346

$rad = "$me 0 obj<<";

3347

if (exists $entry{'text'})

3348

{ $rad .= "/Title ($entry{'text'})";

3349

}

3350

$rad .= "/Parent $parent 0 R";

3351

if (defined $jsObj)

3352

{ $rad .= "/A $jsObj 0 R";

3353

}

3354

if (exists $entry{'act'})

3355

{ my $code = $entry{'act'};

3356

if ($code =~ m/(\d+)/os)

3357

{

3358

$code = $1;

3359

}

3360

$rad .= "/Dest [$code /XYZ null null null] ";

3361

}

3362

if (exists $entry{'previous'})

3363

{ $rad .= "/Prev $entry{'previous'} 0 R";

3364

}

3365

if (exists $entry{'next'})

3366

{ $rad .= "/Next $entry{'next'} 0 R";

3367

}

3368

if (defined $first)

3369

{ $rad .= "/First $first 0 R";

3370

}

3371

if (defined $last)

3372

{ $rad .= "/Last $last 0 R";

3373

}

3374

if ($count != $totalCount)

3375

{ $count = $totalCount - $count;

3376

$rad .= "/Count $count";

3377

}

3378

if (exists $entry{'color'})

3379

{ $rad .= "/C [$entry{'color'}]";

3380

}

3381

if (exists $entry{'style'})

3382

{ $rad .= "/F $entry{'style'}";

3383

}

3384

3385

$rad .= ">>endobj\n";

3386

$pos += syswrite UTFIL, $rad;

3387

}

3388

3389

sub prInitVars

3390

{ my $exit = shift;

3391

$genLowerX = 0;

3392

$genLowerY = 0;

3393

$genUpperX = 595,

3394

$genUpperY = 842;

3395

$fontSize = 12;

3396

($utfil, $slutNod, $formCont, $imSeq,

3397

$page, $sidObjNr, $interActive, $NamesSaved, $AARootSaved, $AAPageSaved,

3398

$root, $AcroFormSaved, $id, $ldir, $checkId, $formNr, $imageNr,

3399

$filnamn, $interAktivSida, $taInterAkt, $type, $runfil, $checkCs,

3400

$confuseObj, $compress,$pos, $fontNr, $objNr,

3401

$defGState, $gSNr, $pattern, $shading, $colorSpace) = '';

3402

3403

if ($docProxy)

3404

{ for my $obj (values %{ $docProxy->{' objcache'} })

3405

{ if ($obj->isa('Text::PDF::TTFont0'))

3406

{ if (my $font = delete $obj->{' font'})

3407

{ $font->release();

3408

}

3409

$obj->release();

3410

}

3411

}

3412

undef $docProxy;

3413

}

3414

3415

(@kids, @counts, @formBox, @objekt, @parents, @aktuellFont, @skapa,

3416

@jsfiler, @inits, @bookmarks, @annots) = ();

3417

3418

( %resurser, %objRef, %nyaFunk,%oldObject, %unZipped,

3419

%sidFont, %sidXObject, %sidExtGState, %font, %fields, %script,

3420

%initScript, %sidPattern, %sidShading, %sidColorSpace, %knownToFile,

3421

%processed, %dummy) = ();

3422

3423

$stream = '';

3424

$idTyp = '';

3425

$ddir = '';

3426

$log = '';

3427

3428

if ($exit)

3429

{ return 1;

3430

}

3431

3432

( %form, %image, %fontSource, %intAct) = ();

3433

3434

return 1;

3435

}

3436

3437

####################

3438

# Behandla en bild

3439

####################

3440

3441

sub prImage

3442

{ my $param = shift;

3443

my ($infil, $sidnr, $bildnr, $effect, $adjust, $x, $y, $size, $xsize,

3444

$ysize, $rotate);

3445

3446

if (ref($param) eq 'HASH')

3447

{ $infil = $param->{'file'};

3448

$sidnr = $param->{'page'} || 1;

3449

$bildnr = $param->{'imageNo'} || 1;

3450

$effect = $param->{'effect'} || 'print';

3451

$adjust = $param->{'adjust'} || '';

3452

$x = $param->{'x'} || 0;

3453

$y = $param->{'y'} || 0;

3454

$rotate = $param->{'rotate'} || 0;

3455

$size = $param->{'size'} || 1;

3456

$xsize = $param->{'xsize'} || 1;

3457

$ysize = $param->{'ysize'} || 1;

3458

}

3459

else

3460

{ $infil = $param;

3461

$sidnr = shift || 1;

3462

$bildnr = shift || 1;

3463

$effect = shift || 'print';

3464

$adjust = shift || '';

3465

$x = shift || 0;

3466

$y = shift || 0;

3467

$rotate = shift || 0;

3468

$size = shift || 1;

3469

$xsize = shift || 1;

3470

$ysize = shift || 1;

3471

}

3472

3473

my ($refNr, $inamn, $bildIndex, $xc, $yc, $xs, $ys);

3474

$type = 'image';

3475

3476

$bildIndex = $bildnr - 1;

3477

my $fSource = $infil . '_' . $sidnr;

3478

my $iSource = $fSource . '_' . $bildnr;

3479

if (! exists $image{$iSource})

3480

{ $imageNr++;

3481

$inamn = 'Ig' . $imageNr;

3482

$knownToFile{'Ig:' . $iSource} = $inamn;

3483

$image{$iSource}[imXPOS] = 0;

3484

$image{$iSource}[imYPOS] = 0;

3485

$image{$iSource}[imXSCALE] = 1;

3486

$image{$iSource}[imYSCALE] = 1;

3487

if (! exists $form{$fSource} )

3488

{ $refNr = getPage($infil, $sidnr, '');

3489

if ($refNr)

3490

{ $formNr++;

3491

my $namn = 'Fm' . $formNr;

3492

$knownToFile{$fSource} = $namn;

3493

}

3494

elsif ((defined $refNr) && ($refNr eq '0'))

3495

{ errLog("File: $infil Page: $sidnr can't be found");

3496

}

3497

}

3498

my $in = $form{$fSource}[fIMAGES][$bildIndex];

3499

$image{$iSource}[imWIDTH] = $form{$fSource}->[fOBJ]->{$in}->[oWIDTH];

3500

$image{$iSource}[imHEIGHT] = $form{$fSource}->[fOBJ]->{$in}->[oHEIGHT];

3501

$image{$iSource}[imIMAGENO] = $form{$fSource}[fIMAGES][$bildIndex];

3502

}

3503

if (exists $knownToFile{'Ig:' . $iSource})

3504

{ $inamn = $knownToFile{'Ig:' . $iSource};

3505

}

3506

else

3507

{ $imageNr++;

3508

$inamn = 'Ig' . $imageNr;

3509

$knownToFile{'Ig:' . $iSource} = $inamn;

3510

}

3511

if (! exists $objRef{$inamn})

3512

{ $refNr = getImage($infil, $sidnr,

3513

$bildnr, $image{$iSource}[imIMAGENO]);

3514

$objRef{$inamn} = $refNr;

3515

}

3516

else

3517

{ $refNr = $objRef{$inamn};

3518

}

3519

3520

my @iData = @{$image{$iSource}};

3521

3522

if (($effect eq 'print') && ($refNr))

3523

{ if (! defined $defGState)

3524

{ prDefaultGrState();}

3525

$stream .= "\n/Gs0 gs\n";

3526

$stream .= "q\n";

3527

3528

if ($adjust)

3529

{ $stream .= fillTheForm(0, 0, $iData[imWIDTH], $iData[imHEIGHT],$adjust);

3530

}

3531

else

3532

{ my $tX = ($x + $iData[imXPOS]);

3533

my $tY = ($y + $iData[imYPOS]);

3534

$stream .= calcMatrix($tX, $tY, $rotate, $size,

3535

$xsize, $ysize, $iData[imWIDTH], $iData[imHEIGHT]);

3536

}

3537

$stream .= "$iData[imWIDTH] 0 0 $iData[imHEIGHT] 0 0 cm\n";

3538

$stream .= "/$inamn Do\n";

3539

$sidXObject{$inamn} = $refNr;

3540

$stream .= "Q\n";

3541

$sidExtGState{'Gs0'} = $defGState;

3542

}

3543

if ($runfil)

3544

{ $infil = prep($infil);

3545

$log .= "Image~$infil~$sidnr~$bildnr~$effect~$adjust";

3546

$log .= "$x~$y~$size~$xsize~$ysize~$rotate\n";

3547

}

3548

if (! $pos)

3549

{ errLog("No output file, you have to call prFile first");

3550

}

3551

3552

if (wantarray)

3553

{ return ($inamn, $iData[imWIDTH], $iData[imHEIGHT]);

3554

}

3555

else

3556

{ return $inamn;

3557

}

3558

}

3559

3560

3561

3562

sub prMbox

3563

{ my $lx = defined($_[0]) ? shift : 0;

3564

my $ly = defined($_[0]) ? shift : 0;

3565

my $ux = defined($_[0]) ? shift : 595;

3566

my $uy = defined($_[0]) ? shift : 842;

3567

3568

if ((defined $lx) && ($lx =~ m'^[\d\-\.]+$'o))

3569

{ $genLowerX = $lx; }

3570

if ((defined $ly) && ($ly =~ m'^[\d\-\.]+$'o))

3571

{ $genLowerY = $ly; }

3572

if ((defined $ux) && ($ux =~ m'^[\d\-\.]+$'o))

3573

{ $genUpperX = $ux; }

3574

if ((defined $uy) && ($uy =~ m'^[\d\-\.]+$'o))

3575

{ $genUpperY = $uy; }

3576

if ($runfil)

3577

{ $log .= "Mbox~$lx~$ly~$ux~$uy\n";

3578

}

3579

if (! $pos)

3580

{ errLog("No output file, you have to call prFile first");

3581

}

3582

3583

}

3584

3585

sub prField

3586

{ my ($fieldName, $fieldValue) = @_;

3587

if (($interAktivSida) || ($interActive))

3588

{ errLog("Too late, has already tried to INITIATE FIELDS within an interactive page");

3589

}

3590

elsif (! $pos)

3591

{ errLog("Too early INITIATE FIELDS, create a file first");

3592

}

3593

$fields{$fieldName} = $fieldValue;

3594

if ($fieldValue =~ m'^\s*js\s*\:(.*)'oi)

3595

{ my $code = $1;

3596

my @fall = ($code =~ m'([\w\d\_\$]+)\s*$.*?$'gs);

3597

for (@fall)

3598

{ if (! exists $initScript{$_})

3599

{ $initScript{$_} = 0;

3600

}

3601

}

3602

}

3603

if ($runfil)

3604

{ $fieldName = prep($fieldName);

3605

$fieldValue = prep($fieldValue);

3606

$log .= "Field~$fieldName~$fieldValue\n";

3607

}

3608

3609

}

3610

############################################################

3611

sub prBar

3612

{ my ($xPos, $yPos, $TxT) = @_;

3613

3614

$TxT =~ tr/G/2/;

3615

3616

my @fontSpar = @aktuellFont;

3617

3618

findBarFont();

3619

3620

my $Font = $aktuellFont[foINTNAMN]; # Namn i str�mmen

3621

3622

if (($xPos) && ($yPos))

3623

{ $stream .= "\nBT /$Font $fontSize Tf ";

3624

$stream .= "$xPos $yPos Td $$TxT$ Tj ET\n";

3625

}

3626

if ($runfil)

3627

{ $log .= "Bar~$xPos~$yPos~$TxT\n";

3628

}

3629

if (! $pos)

3630

{ errLog("No output file, you have to call prFile first");

3631

}

3632

@aktuellFont = @fontSpar;

3633

return $Font;

3634

3635

}

3636

3637

3638

sub prExtract

3639

{ my $name = shift;

3640

my $form = shift;

3641

my $page = shift || 1;

3642

if ($name =~ m'^/(\w+)'o)

3643

{ $name = $1;

3644

}

3645

my $fullName = "$name~$form~$page";

3646

if (exists $knownToFile{$fullName})

3647

{ return $knownToFile{$fullName};

3648

}

3649

else

3650

{ if ($runfil)

3651

{ $log = "Extract~$fullName\n";

3652

}

3653

if (! $pos)

3654

{ errLog("No output file, you have to call prFile first");

3655

}

3656

3657

if (! exists $form{$form . '_' . $page})

3658

{ prForm($form, $page, undef, 'load', 1);

3659

}

3660

$name = extractName($form, $page, $name);

3661

if ($name)

3662

{ $knownToFile{$fullName} = $name;

3663

}

3664

return $name;

3665

}

3666

}

3667

3668

3669

########## Extrahera ett dokument ####################

3670

sub prDoc

3671

{ my ($infil, $first, $last);

3672

my $param = shift;

3673

if (ref($param) eq 'HASH')

3674

{ $infil = $param->{'file'};

3675

$first = $param->{'first'} || 1;

3676

$last = $param->{'last'} || '';

3677

}

3678

else

3679

{ $infil = $param;

3680

$first = shift || 1;

3681

$last = shift || '';

3682

}

3683

3684

3685

my ($sidor, $Names, $AARoot, $AcroForm) = analysera($infil, $first, $last);

3686

if (($Names) || ($AARoot) || ($AcroForm))

3687

{ $NamesSaved = $Names;

3688

$AARootSaved = $AARoot;

3689

$AcroFormSaved = $AcroForm;

3690

$interActive = 1;

3691

}

3692

if ($runfil)

3693

{ $infil = prep($infil);

3694

$log .= "Doc~$infil~$first~$last\n";

3695

}

3696

if (! $pos)

3697

{ errLog("No output file, you have to call prFile first");

3698

}

3699

return $sidor;

3700

}

3701

3702

############# Ett interaktivt + grafiskt "formul�r" ##########

3703

3704

sub prDocForm

3705

{my ($sidnr, $adjust, $effect, $tolerant, $infil, $x, $y, $size, $xsize,

3706

$ysize, $rotate);

3707

my $param = shift;

3708

if (ref($param) eq 'HASH')

3709

{ $infil = $param->{'file'};

3710

$sidnr = $param->{'page'} || 1;

3711

$adjust = $param->{'adjust'} || '';

3712

$effect = $param->{'effect'} || 'print';

3713

$tolerant = $param->{'tolerant'} || '';

3714

$x = $param->{'x'} || 0;

3715

$y = $param->{'y'} || 0;

3716

$rotate = $param->{'rotate'} || 0;

3717

$size = $param->{'size'} || 1;

3718

$xsize = $param->{'xsize'} || 1;

3719

$ysize = $param->{'ysize'} || 1;

3720

}

3721

else

3722

{ $infil = $param;

3723

$sidnr = shift || 1;

3724

$adjust = shift || '';

3725

$effect = shift || 'print';

3726

$tolerant = shift || '';

3727

$x = shift || 0;

3728

$y = shift || 0;

3729

$rotate = shift || 0;

3730

$size = shift || 1;

3731

$xsize = shift || 1;

3732

$ysize = shift || 1;

3733

}

3734

my $namn;

3735

my $refNr;

3736

$type = 'docform';

3737

my $fSource = $infil . '_' . $sidnr;

3738

my $action;

3739

if (! exists $form{$fSource})

3740

{ $formNr++;

3741

$namn = 'Fm' . $formNr;

3742

$knownToFile{$fSource} = $namn;

3743

if ($effect eq 'load')

3744

{ $action = 'load'

3745

}

3746

else

3747

{ $action = 'print'

3748

}

3749

$refNr = getPage($infil, $sidnr, $action);

3750

if ($refNr)

3751

{ $objRef{$namn} = $refNr;

3752

}

3753

else

3754

{ if ($tolerant)

3755

{ if ((defined $refNr) && ($refNr eq '0')) # Sidnumret existerar inte, men ok

3756

{ $namn = '0';

3757

}

3758

else

3759

{ undef $namn; # Sidan kan inte anv�ndas som form

3760

}

3761

}

3762

elsif (! defined $refNr)

3763

{ my $mess = "$fSource can't be used as a form. See the documentation\n"

3764

. "under prForm how to concatenate streams\n";

3765

errLog($mess);

3766

}

3767

else

3768

{ errLog("File : $infil Page: $sidnr doesn't exist");

3769

}

3770

}

3771

}

3772

else

3773

{ if (exists $knownToFile{$fSource})

3774

{ $namn = $knownToFile{$fSource};

3775

}

3776

else

3777

{ $formNr++;

3778

$namn = 'Fm' . $formNr;

3779

$knownToFile{$fSource} = $namn;

3780

}

3781

if (exists $objRef{$namn})

3782

{ $refNr = $objRef{$namn};

3783

}

3784

else

3785

{ if (! $form{$fSource}[fVALID])

3786

{ my $mess = "$fSource can't be used as a form. See the documentation\n"

3787

. "under prForm how to concatenate streams\n";

3788

if ($tolerant)

3789

{ cluck $mess;

3790

undef $namn;

3791

}

3792

else

3793

{ errLog($mess);

3794

}

3795

}

3796

elsif ($effect ne 'load')

3797

{ $refNr = byggForm($infil, $sidnr);

3798

$objRef{$namn} = $refNr;

3799

}

3800

}

3801

}

3802

my @BBox = @{$form{$fSource}[fBBOX]} if ($refNr);

3803

if (($effect eq 'print') && ($form{$fSource}[fVALID]) && ($refNr))

3804

{ if ((! defined $interActive)

3805

&& ($sidnr == 1)

3806

&& (%{$intAct{$fSource}[0]}) )

3807

{ $interActive = $infil . ' ' . $sidnr;

3808

$interAktivSida = 1;

3809

}

3810

if (! defined $defGState)

3811

{ prDefaultGrState();

3812

}

3813

if ($adjust)

3814

{ $stream .= "q\n";

3815

$stream .= fillTheForm(@BBox, $adjust);

3816

$stream .= "\n/Gs0 gs\n";

3817

$stream .= "/$namn Do\n";

3818

$stream .= "Q\n";

3819

}

3820

elsif (($x) || ($y) || ($rotate) || ($size != 1)

3821

|| ($xsize != 1) || ($ysize != 1))

3822

{ $stream .= "q\n";

3823

$stream .= calcMatrix($x, $y, $rotate, $size,

3824

$xsize, $ysize, $BBox[2], $BBox[3]);

3825

$stream .= "\n/Gs0 gs\n";

3826

$stream .= "/$namn Do\n";

3827

$stream .= "Q\n";

3828

}

3829

else

3830

{ $stream .= "\n/Gs0 gs\n";

3831

$stream .= "/$namn Do\n";

3832

}

3833

$sidXObject{$namn} = $refNr;

3834

$sidExtGState{'Gs0'} = $defGState;

3835

}

3836

if ($runfil)

3837

{ $infil = prep($infil);

3838

$log .= "Form~$infil~$sidnr~$adjust~$effect~$tolerant";

3839

$log .= "~$x~$y~$rotate~$size~$xsize~$ysize\n";

3840

}

3841

if (! $pos)

3842

{ errLog("No output file, you have to call prFile first");

3843

}

3844

if (($effect ne 'print') && ($effect ne 'add'))

3845

{ undef $namn;

3846

}

3847

if (wantarray)

3848

{ my $images = 0;

3849

if (exists $form{$fSource}[fIMAGES])

3850

{ $images = scalar(@{$form{$fSource}[fIMAGES]});

3851

}

3852

return ($namn, $BBox[0], $BBox[1], $BBox[2],

3853

$BBox[3], $images);

3854

}

3855

else

3856

{ return $namn;

3857

}

3858

}

3859

3860

sub calcMatrix

3861

{ my ($x, $y, $rotate, $size, $xsize, $ysize, $upperX, $upperY) = @_;

3862

my ($str, $xSize, $ySize);

3863

$size = 1 if ($size == 0);

3864

$xsize = 1 if ($xsize == 0);

3865

$ysize = 1 if ($ysize == 0);

3866

$xSize = $xsize * $size;

3867

$ySize = $ysize * $size;

3868

$str = "$xSize 0 0 $ySize $x $y cm\n";

3869

if ($rotate)

3870

{ if ($rotate =~ m'q(\d)'oi)

3871

{ my $tal = $1;

3872

if ($tal == 1)

3873

{ $upperY = $upperX;

3874

$upperX = 0;

3875

$rotate = 270;

3876

}

3877

elsif ($tal == 2)

3878

{ $rotate = 180;

3879

}

3880

else

3881

{ $rotate = 90;

3882

$upperX = $upperY;

3883

$upperY = 0;

3884

}

3885

}

3886

else

3887

{ $upperX = 0;

3888

$upperY = 0;

3889

}

3890

my $radian = sprintf("%.6f", $rotate / 57.2957795); # approx.

3891

my $Cos = sprintf("%.6f", cos($radian));

3892

my $Sin = sprintf("%.6f", sin($radian));

3893

my $negSin = $Sin * -1;

3894

$str .= "$Cos $Sin $negSin $Cos $upperX $upperY cm\n";

3895

}

3896

return $str;

3897

}

3898

3899

sub fillTheForm

3900

{ my $left = shift || 0;

3901

my $bottom = shift || 0;

3902

my $right = shift || 0;

3903

my $top = shift || 0;

3904

my $how = shift || 1;

3905

my $image = shift;

3906

my $str;

3907

my $scaleX = 1;

3908

my $scaleY = 1;

3909

3910

my $xDim = $genUpperX - $genLowerX;

3911

my $yDim = $genUpperY - $genLowerY;

3912

my $xNy = $right - $left;

3913

my $yNy = $top - $bottom;

3914

$scaleX = $xDim / $xNy;

3915

$scaleY = $yDim / $yNy;

3916

if ($how == 1)

3917

{ if ($scaleX < $scaleY)

3918

{ $scaleY = $scaleX;

3919

}

3920

else

3921

{ $scaleX = $scaleY;

3922

}

3923

}

3924

$str = "$scaleX 0 0 $scaleY $left $bottom cm\n";

3925

return $str;

3926

}

3927

3928

sub prAltJpeg

3929

{ my ($iData, $iWidth, $iHeight, $iFormat,$aiData, $aiWidth, $aiHeight, $aiFormat) = @_;

3930

if (! $pos) # If no output is active, it is no use to continue

3931

{ return undef;

3932

}

3933

prJpeg($aiData, $aiWidth, $aiHeight, $aiFormat);

3934

my $altObjNr = $objNr;

3935

$imageNr++;

3936

$objNr++;

3937

$objekt[$objNr] = $pos;

3938

my $utrad = "$objNr 0 obj\n" .

3939

"[ << /Image $altObjNr 0 R\n" .

3940

"/DefaultForPrinting true\n" .

3941

">>\n" .

3942

"]\n" .

3943

"endobj\n";

3944

$pos += syswrite UTFIL, $utrad;

3945

if ($runfil)

3946

{ $log .= "Jpeg~AltImage\n";

3947

}

3948

my $namnet = prJpeg($iData, $iWidth, $iHeight, $iFormat, $objNr);

3949

$objRef{$namnet} = $objNr;

3950

if (! $pos)

3951

{ errLog("No output file, you have to call prFile first");

3952

}

3953

return $namnet;

3954

}

3955

3956

sub prJpeg

3957

{ my ($iData, $iWidth, $iHeight, $iFormat, $iColorType, $altArrayObjNr) = @_;

3958

if ($iColorType =~ /Gray/i)

3959

{ $iColorType = 'DeviceGray';

3960

}

3961

else

3962

{ $iColorType = 'DeviceRGB';

3963

}

3964

my ($iLangd, $namnet, $utrad, $iFile);

3965

if (! $pos) # If no output is active, it is no use to continue

3966

{ return undef;

3967

}

3968

my $checkidOld = $checkId;

3969

if (!$iFormat)

3970

{ ($iFile, $checkId) = findGet($iData, $checkidOld);

3971

if ($iFile)

3972

{ $iLangd = (stat($iFile))[7];

3973

$imageNr++;

3974

$namnet = 'Ig' . $imageNr;

3975

$objNr++;

3976

$objekt[$objNr] = $pos;

3977

open (BILDFIL, "<$iFile") || errLog("Couldn't open $iFile, $!, aborts");

3978

binmode BILDFIL;

3979

my $iStream;

3980

sysread BILDFIL, $iStream, $iLangd;

3981

$utrad = "$objNr 0 obj\n<

3982

"/Width $iWidth /Height $iHeight /BitsPerComponent 8 " .

3983

($altArrayObjNr ? "/Alternates $altArrayObjNr 0 R " : "") .

3984

"/Filter/DCTDecode/ColorSpace/$iColorType"

3985

. "/Length $iLangd >>stream\n$iStream\nendstream\nendobj\n";

3986

close BILDFIL;

3987

$pos += syswrite UTFIL, $utrad;

3988

if ($runfil)

3989

{ $log .= "Cid~$checkId\n";

3990

$log .= "Jpeg~$iFile~$iWidth~$iHeight\n";

3991

}

3992

$objRef{$namnet} = $objNr;

3993

}

3994

}

3995

elsif ($iFormat == 1)

3996

{ my $iBlob = $iData;

3997

$iLangd = length($iBlob);

3998

$imageNr++;

3999

$namnet = 'Ig' . $imageNr;

4000

$objNr++;

4001

$objekt[$objNr] = $pos;

4002

$utrad = "$objNr 0 obj\n<

4003

"/Width $iWidth /Height $iHeight /BitsPerComponent 8 " .

4004

($altArrayObjNr ? "/Alternates $altArrayObjNr 0 R " : "") .

4005

"/Filter/DCTDecode/ColorSpace/$iColorType"

4006

. "/Length $iLangd >>stream\n$iBlob\nendstream\nendobj\n";

4007

$pos += syswrite UTFIL, $utrad;

4008

if ($runfil)

4009

{ $log .= "Cid~$checkId\n";

4010

$log .= "Jpeg~$iFile~$iWidth~$iHeight\n" if !$iFormat;

4011

$log .= "Jpeg~Blob~$iWidth~$iHeight\n" if $iFormat == 1;

4012

}

4013

$objRef{$namnet} = $objNr;

4014

}

4015

if (! $pos)

4016

{ errLog("No output file, you have to call prFile first");

4017

}

4018

undef $checkId;

4019

return $namnet;

4020

}

4021

4022

sub checkContentStream

4023

{ for (@_)

4024

{ if (my $value = $objRef{$_})

4025

{ my $typ = substr($_, 0, 2);

4026

if ($typ eq 'Ft')

4027

{ $sidFont{$_} = $value;

4028

}

4029

elsif ($typ eq 'Gs')

4030

{ $sidExtGState{$_} = $value;

4031

}

4032

elsif ($typ eq 'Pt')

4033

{ $sidPattern{$_} = $value;

4034

}

4035

elsif ($typ eq 'Sh')

4036

{ $sidShading{$_} = $value;

4037

}

4038

elsif ($typ eq 'Cs')

4039

{ $sidColorSpace{$_} = $value;

4040

}

4041

else

4042

{ $sidXObject{$_} = $value;

4043

}

4044

}

4045

elsif (($_ eq 'Gs0') && (! defined $defGState))

4046

{ my ($dummy, $oNr) = prDefaultGrState();

4047

$sidExtGState{'Gs0'} = $oNr;

4048

}

4049

}

4050

}

4051

4052

sub prGraphState

4053

{ my $string = shift;

4054

$gSNr++;

4055

my $name = 'Gs' . $gSNr ;

4056

$objNr++;

4057

$objekt[$objNr] = $pos;

4058

my $utrad = "$objNr 0 obj\n" . $string . "\nendobj\n";

4059

$pos += syswrite UTFIL, $utrad;

4060

$objRef{$name} = $objNr;

4061

if ($runfil)

4062

{ $log .= "GraphStat~$string\n";

4063

}

4064

if (! $pos)

4065

{ errLog("No output file, you have to call prFile first");

4066

}

4067

return $name;

4068

}

4069

4070

##############################################################

4071

# Streckkods fonten lokaliseras och objekten skrivs ev. ut

4072

##############################################################

4073

4074

sub findBarFont()

4075

{ my $Font = 'Bar';

4076

4077

if (exists $font{$Font}) # Objekt �r redan definierat

4078

{ $aktuellFont[foEXTNAMN] = $Font;

4079

$aktuellFont[foREFOBJ] = $font{$Font}[foREFOBJ];

4080

$aktuellFont[foINTNAMN] = $font{$Font}[foINTNAMN];

4081

}

4082

else

4083

{ $objNr++;

4084

$objekt[$objNr] = $pos;

4085

my $encodObj = $objNr;

4086

my $fontObjekt = "$objNr 0 obj\n<< /Type /Encoding\n" .

4087

'/Differences [48 /tomt /streck /lstreck]' . "\n>>\nendobj\n";

4088

$pos += syswrite UTFIL, $fontObjekt;

4089

my $charProcsObj = createCharProcs();

4090

$objNr++;

4091

$objekt[$objNr] = $pos;

4092

$fontNr++;

4093

my $fontAbbr = 'Ft' . $fontNr;

4094

$fontObjekt = "$objNr 0 obj\n<

4095

'/FontBBox [0 -250 75 2000]' . "\n" .

4096

'/FontMatrix [0.001 0 0 0.001 0 0]' . "\n" .

4097

"\/CharProcs $charProcsObj 0 R\n" .

4098

"\/Encoding $encodObj 0 R\n" .

4099

'/FirstChar 48' . "\n" .

4100

'/LastChar 50' . "\n" .

4101

'/Widths [75 75 75]' . "\n>>\nendobj\n";

4102

4103

$font{$Font}[foINTNAMN] = $fontAbbr;

4104

$font{$Font}[foREFOBJ] = $objNr;

4105

$objRef{$fontAbbr} = $objNr;

4106

$objekt[$objNr] = $pos;

4107

$aktuellFont[foEXTNAMN] = $Font;

4108

$aktuellFont[foREFOBJ] = $objNr;

4109

$aktuellFont[foINTNAMN] = $fontAbbr;

4110

$pos += syswrite UTFIL, $fontObjekt;

4111

}

4112

if (! $pos)

4113

{ errLog("No output file, you have to call prFile first");

4114

}

4115

4116

$sidFont{$aktuellFont[foINTNAMN]} = $aktuellFont[foREFOBJ];

4117

}

4118

4119

sub createCharProcs()

4120

{ #################################

4121

# Fonten (objektet) f�r 0 skapas

4122

#################################

4123

4124

$objNr++;

4125

$objekt[$objNr] = $pos;

4126

my $tomtObj = $objNr;

4127

my $str = "\n75 0 d0\n6 0 69 2000 re\n1.0 g\nf\n";

4128

my $strLength = length($str);

4129

my $obj = "$objNr 0 obj\n<< /Length $strLength >>\nstream" .

4130

$str . "\nendstream\nendobj\n";

4131

$pos += syswrite UTFIL, $obj;

4132

4133

#################################

4134

# Fonten (objektet) f�r 1 skapas

4135

#################################

4136

4137

$objNr++;

4138

$objekt[$objNr] = $pos;

4139

my $streckObj = $objNr;

4140

$str = "\n75 0 d0\n4 0 71 2000 re\n0.0 g\nf\n";

4141

$strLength = length($str);

4142

$obj = "$objNr 0 obj\n<< /Length $strLength >>\nstream" .

4143

$str . "\nendstream\nendobj\n";

4144

$pos += syswrite UTFIL, $obj;

4145

4146

###################################################

4147

# Fonten (objektet) f�r 2, ett l�ngt streck skapas

4148

###################################################

4149

4150

$objNr++;

4151

$objekt[$objNr] = $pos;

4152

my $lStreckObj = $objNr;

4153

$str = "\n75 0 d0\n4 -250 71 2250 re\n0.0 g\nf\n";

4154

$strLength = length($str);

4155

$obj = "$objNr 0 obj\n<< /Length $strLength >>\nstream" .

4156

$str . "\nendstream\nendobj\n";

4157

$pos += syswrite UTFIL, $obj;

4158

4159

#####################################################

4160

# Objektet f�r "CharProcs" skapas

4161

#####################################################

4162

4163

$objNr++;

4164

$objekt[$objNr] = $pos;

4165

my $charProcsObj = $objNr;

4166

$obj = "$objNr 0 obj\n<

4167

"/lstreck $lStreckObj 0 R>>\nendobj\n";

4168

$pos += syswrite UTFIL, $obj;

4169

return $charProcsObj;

4170

}

4171

4172

4173

4174

sub prCid

4175

{ $checkId = shift;

4176

if ($runfil)

4177

{ $log .= "Cid~$checkId\n";

4178

}

4179

4180

}

4181

4182

sub prIdType

4183

{ $idTyp = shift;

4184

if ($runfil)

4185

{ $log .= "IdType~rep\n";

4186

}

4187

4188

}

4189

4190

4191

sub prId

4192

{ $id = shift;

4193

if ($runfil)

4194

{ $log .= "Id~$id\n";

4195

}

4196

if (! $pos)

4197

{ errLog("No output file, you have to call prFile first");

4198

}

4199

4200

}

4201

4202

sub prJs

4203

{ my $filNamnIn = shift;

4204

my $filNamn;

4205

if ($filNamnIn !~ m'\{'os)

4206

{ my $checkIdOld = $checkId;

4207

($filNamn, $checkId) = findGet($filNamnIn, $checkIdOld);

4208

if (($runfil) && ($checkId) && ($checkId ne $checkIdOld))

4209

{ $log .= "Cid~$checkId\n";

4210

}

4211

$checkId = '';

4212

}

4213

else

4214

{ $filNamn = $filNamnIn;

4215

}

4216

if ($runfil)

4217

{ my $filnamn = prep($filNamn);

4218

$log .= "Js~$filnamn\n";

4219

}

4220

if (($interAktivSida) || ($interActive))

4221

{ errLog("Too late, has already tried to merge JAVA SCRIPTS within an interactive page");

4222

}

4223

elsif (! $pos)

4224

{ errLog("Too early for JAVA SCRIPTS, create a file first");

4225

}

4226

push @jsfiler, $filNamn;

4227

4228

}

4229

4230

sub prInit

4231

{ my $initText = shift;

4232

my $duplicate = shift || '';

4233

my @fall = ($initText =~ m'([\w\d\_\$]+)\s*$.*?$'gs);

4234

for (@fall)

4235

{ if (! exists $initScript{$_})

4236

{ $initScript{$_} = 0;

4237

}

4238

}

4239

if ($duplicate)

4240

{ $duplicateInits = 1;

4241

}

4242

push @inits, $initText;

4243

if ($runfil)

4244

{ $initText = prep($initText);

4245

$log .= "Init~$initText~$duplicate\n";

4246

}

4247

if (($interAktivSida) || ($interActive))

4248

{ errLog("Too late, has already tried to create INITIAL JAVA SCRIPTS within an interactive page");

4249

}

4250

elsif (! $pos)

4251

{ errLog("Too early for INITIAL JAVA SCRIPTS, create a file first");

4252

}

4253

4254

4255

}

4256

4257

sub prVers

4258

{ my $vers = shift;

4259

############################################################

4260

# Om programmet k�rs om s� kontrolleras VERSION

4261

############################################################

4262

if ($vers ne $VERSION)

4263

{ warn "$vers \<\> $VERSION might give different results, if comparing two runs \n";

4264

return undef;

4265

}

4266

else

4267

{ return 1;

4268

}

4269

}

4270

4271

sub prDocDir

4272

{ $ddir = findDir(shift);

4273

4274

}

4275

4276

sub prLogDir

4277

{ $ldir = findDir(shift);

4278

4279

}

4280

4281

sub prLog

4282

{ my $mess = shift;

4283

if ($runfil)

4284

{ $mess = prep($mess);

4285

$log .= "Log~$mess\n";

4286

return 1;

4287

}

4288

else

4289

{ errLog("You have to give a directory for the logfiles first : prLogDir , aborts");

4290

}

4291

4292

}

4293

4294

sub prGetLogBuffer

4295

{

4296

return $log;

4297

}

4298

4299

sub findDir

4300

{ my $dir = shift;

4301

if ($dir eq '.')

4302

{ return undef; }

4303

if (! -e $dir)

4304

{ mkdir $dir || errLog("Couldn't create directory $dir, $!");

4305

}

4306

4307

if ((-e $dir) && (-d $dir))

4308

{ if (substr($dir, length($dir), 1) eq '/')

4309

{ return $dir; }

4310

else

4311

{ return ($dir . '/');

4312

}

4313

}

4314

else

4315

{ errLog("Error finding/creating directory $dir, $!");

4316

}

4317

}

4318

4319

sub prTouchUp

4320

{ $touchUp = shift;

4321

if ($runfil)

4322

{ $log .= "TouchUp~$touchUp\n";

4323

}

4324

if (! $pos)

4325

{ errLog("No output file, you have to call prFile first");

4326

}

4327

4328

}

4329

4330

sub prCompress

4331

{ $compress = shift;

4332

if ($runfil)

4333

{ $log .= "Compress~$compress\n";

4334

}

4335

if (! $pos)

4336

{ errLog("No output file, you have to call prFile first");

4337

}

4338

4339

4340

}

4341

4342

sub prep

4343

{ my $indata = shift;

4344

$indata =~ s/[\n\r]+/ /sgo;

4345

$indata =~ s/~//sgo;

4346

return $indata;

4347

}

4348

4349

4350

sub xRefs

4351

{ my ($bytes, $infil) = @_;

4352

my ($j, $nr, $xref, $i, $antal, $inrad, $Root, $tempRoot, $referens);

4353

my $buf = '';

4354

%embedded =();

4355

4356

my $res = sysseek INFIL, -50, 2;

4357

if ($res)

4358

{ sysread INFIL, $buf, 100;

4359

if ($buf =~ m'Encrypt'o)

4360

{ errLog("The file $infil is encrypted, cannot be used, aborts");

4361

}

4362

if ($buf =~ m/\bstartxref$ws+(\d+)/)

4363

{ $xref = $1;

4364

if ($xref <= $bytes)

4365

{

4366

while ($xref)

4367

{ $res = sysseek INFIL, $xref, 0;

4368

$res = sysread INFIL, $buf, 200;

4369

if ($buf =~ m /^\d+$ws+\d+$ws+obj/os)

4370

{ ($xref, $tempRoot, $nr) = crossrefObj($nr, $xref);

4371

}

4372

else

4373

{ ($xref, $tempRoot, $nr) = xrefSection($nr, $xref, $infil);

4374

}

4375

if (($tempRoot) && (! $Root))

4376

{ $Root = $tempRoot;

4377

}

4378

}

4379

}

4380

else

4381

{ errLog("Invalid XREF, aborting");

4382

}

4383

}

4384

}

4385

4386

($Root) || errLog("The Root object in $infil couldn't be found, aborting");

4387

4388

##############################################################

4389

# Objekten sorteras i fallande ordning (efter offset i filen)

4390

##############################################################

4391

4392

my @offset = sort { $oldObject{$b} <=> $oldObject{$a} } keys %oldObject;

4393

4394

my $saved;

4395

4396

for (@offset)

4397

{ $saved = $oldObject{$_};

4398

$bytes -= $saved;

4399

4400

100

if ($_ !~ m'^xref'o)

4401

{ if ($saved == 0)

4402

{ $oldObject{$_} = [ 0, 0, $embedded{$_}];

4403

}

4404

else

4405

{ $oldObject{$_} = [ $saved, $bytes];

4406

}

4407

}

4408

$bytes = $saved;

4409

}

4410

%embedded = ();

4411

return $Root;

4412

}

4413

4414

sub crossrefObj

4415

{ my ($nr, $xref) = @_;

4416

my ($buf, %param, $len, $tempRoot);

4417

my $from = $xref;

4418

sysseek INFIL, $xref, 0;

4419

sysread INFIL, $buf, 400;

4420

my $str;

4421

if ($buf =~ m/^(.+>>$ws*)stream/os)

4422

{ $str = $1;

4423

$from = length($str) + 7;

4424

if (substr($buf, $from, 1) eq "\n")

4425

{ $from++;

4426

}

4427

$from += $xref;

4428

}

4429

4430

for (split('/',$str))

4431

{ if ($_ =~ m'^(\w+)(.*)'o)

4432

{ $param{$1} = $2 || ' ';

4433

}

4434

}

4435

if (!exists $param{'Index'})

4436

{ $param{'Index'} = "[0 $param{'Size'}]";

4437

}

4438

if ((exists $param{'Root'}) && ($param{'Root'} =~ m/^$ws*(\d+)/o))

4439

{ $tempRoot = $1;

4440

}

4441

my @keys = ($param{'W'} =~ m'(\d+)'og);

4442

my $keyLength = 0;

4443

for (@keys)

4444

{ $keyLength += $_;

4445

}

4446

my $recLength = $keyLength + 1;

4447

my $upTo = 1 + $keys[0] + $keys[1];

4448

if ((exists $param{'Length'}) && ($param{'Length'} =~ m'(\d+)'o))

4449

{ $len = $1;

4450

sysseek INFIL, $from, 0;

4451

sysread INFIL, $buf, $len;

4452

my $x = inflateInit()

4453

|| die "Cannot create an inflation stream\n" ;

4454

my ($output, $status) = $x->inflate(\$buf) ;

4455

die "inflation failed\n"

4456

unless $status == 1;

4457

4458

my $i = 0;

4459

my @last = (0, 0, 0, 0, 0, 0, 0);

4460

my @word = ('0', '0', '0', '0', '0', '0', '0');

4461

my $recTyp;

4462

my @intervall = ($param{'Index'} =~ m'(\d+)\D'osg);

4463

my $m = 0;

4464

my $currObj = $intervall[$m];

4465

$m++;

4466

my $max = $currObj + $intervall[$m];

4467

4468

for (unpack ("C*", $output))

4469

{ if (($_ != 0) && ($i > 0) && ($i < $upTo))

4470

{ my $tal = $_ + $last[$i] ;

4471

if ($tal > 255)

4472

{$tal -= 256;

4473

}

4474

4475

$last[$i] = $tal;

4476

$word[$i] = sprintf("%x", $tal);

4477

if (length($word[$i]) == 1)

4478

{ $word[$i] = '0' . $word[$i];

4479

}

4480

}

4481

$i++;

4482

if ($i == $recLength)

4483

{ $i = 0;

4484

my $j = 0;

4485

my $offsObj; # offset or object

4486

if ($keys[0] == 0)

4487

{ $recTyp = 1;

4488

$j = 1;

4489

}

4490

else

4491

{ $recTyp = hex($word[1]);

4492

$j = 2;

4493

}

4494

my $k = 0;

4495

while ($k < $keys[1])

4496

{ $offsObj .= $word[$j];

4497

$k++;

4498

$j++;

4499

}

4500

4501

if ($recTyp == 1)

4502

{ if (! (exists $oldObject{$currObj}))

4503

{ $oldObject{$currObj} = hex($offsObj); }

4504

else

4505

{ $nr++;

4506

$oldObject{'xref' . "$nr"} = hex($offsObj);

4507

}

4508

}

4509

elsif ($recTyp == 2)

4510

{ if (! (exists $oldObject{$currObj}))

4511

{ $oldObject{$currObj} = 0;

4512

}

4513

$embedded{$currObj} = hex($offsObj);

4514

}

4515

if ($currObj < $max)

4516

{ $currObj++;

4517

}

4518

else

4519

{ $m++;

4520

$currObj = $intervall[$m];

4521

$m++;

4522

$max = $currObj + $intervall[$m];

4523

}

4524

}

4525

}

4526

}

4527

return ($param{'Prev'}, $tempRoot, $nr);

4528

}

4529

4530

sub xrefSection

4531

{ my ($nr, $xref, $infil) = @_;

4532

my ($i, $root, $antal);

4533

$nr++;

4534

$oldObject{('xref' . "$nr")} = $xref; # Offset f�r xref sparas

4535

sysseek INFIL, $xref, 0;

4536

sysread INFIL, my $buf, 30;

4537

if ($buf =~ /xref/) {

4538

sysseek INFIL, $xref+$-[0]+5, 0;

4539

}

4540

else {

4541

# If the regexp fails (it shouldn't), fall back to the previous

4542

# behaviour.

4543

sysseek INFIL, $xref + 5, 0;

4544

}

4545

$xref = 0;

4546

my $inrad = '';

4547

$buf = '';

4548

my $c;

4549

sysread INFIL, $c, 1;

4550

while ($c =~ m!\s!s)

4551

{ sysread INFIL, $c, 1; }

4552

4553

while ( (defined $c)

4554

&& ($c ne "\n")

4555

&& ($c ne "\r") )

4556

{ $inrad .= $c;

4557

sysread INFIL, $c, 1;

4558

}

4559

4560

if ($inrad =~ m'^(\d+)\s+(\d+)'o)

4561

{ $i = $1;

4562

$antal = $2;

4563

}

4564

4565

while ($antal)

4566

{ for (my $l = 1; $l <= $antal; $l++)

4567

{ sysread INFIL, $inrad, 20;

4568

if ($inrad =~ m'^\s?(\d+) \d+ (\w)\s*'o)

4569

100

{ if ($2 eq 'n')

4570

{ if (! (exists $oldObject{$i}))

4571

{ $oldObject{$i} = int($1); }

4572

else

4573

{ $nr++;

4574

$oldObject{'xref' . "$nr"} = int($1);

4575

}

4576

}

4577

}

4578

$i++;

4579

}

4580

undef $antal;

4581

undef $inrad;

4582

sysread INFIL, $c, 1;

4583

while ($c =~ m!\s!s)

4584

{ sysread INFIL, $c, 1; }

4585

4586

while ( (defined $c)

4587

&& ($c ne "\n")

4588

&& ($c ne "\r") )

4589

{ $inrad .= $c;

4590

sysread INFIL, $c, 1;

4591

}

4592

if ($inrad =~ m'^(\d+)\s+(\d+)'o)

4593

{ $i = $1;

4594

$antal = $2;

4595

}

4596

4597

}

4598

4599

while ($inrad)

4600

{ $buf .= $inrad;

4601

if ($buf =~ m'Encrypt'o)

4602

{ errLog("The file $infil is encrypted, cannot be used, aborts");

4603

}

4604

100

if ((! $root) && ($buf =~ m|\/Root$ws+(\d+)$ws+\d+$ws+R|so))

4605

{ $root = $1;

4606

if ($xref)

4607

{ last; }

4608

}

4609

4610

if ((! $xref) && ($buf =~ m|\/Prev$ws+(\d+)\D|so))

4611

{ $xref = $1;

4612

if ($root)

4613

{ last; }

4614

}

4615

4616

100

if ($buf =~ m'xref'so)

4617

{ last; }

4618

4619

if($inrad=~ m/trailer/o && (! $root) && ($inrad =~ m'\/Root\s+(\d+)\s{1,2}\d+\s{1,2}R'so))

4620

{ $root = $1;

4621

if ($xref)

4622

{ last; }

4623

}

4624

4625

sysread INFIL, $inrad, 30;

4626

}

4627

return ($xref, $root, $nr);

4628

}

4629

4630

sub getObject

4631

{ my ($nr, $noId, $noEnd) = @_;

4632

4633

my $buf;

4634

my ($offs, $siz, $embedded) = @{$oldObject{$nr}};

4635

4636

if ($offs)

4637

{ sysseek INFIL, $offs, 0;

4638

sysread INFIL, $buf, $siz;

4639

100

if (($noId) && ($noEnd))

4640

{ if ($buf =~ m/^\d+$ws+\d+$ws+obj$ws*(.*)endobj/os)

4641

{ if (wantarray)

4642

{ return ($1, $offs, $siz, $embedded);

4643

}

4644

else

4645

{ return $1;

4646

}

4647

}

4648

}

4649

elsif ($noId)

4650

{ if ($buf =~ m/^\d+$ws+\d+$ws+obj$ws*(.*)/os)

4651

{ if (wantarray)

4652

{ return ($1, $offs, $siz, $embedded);

4653

}

4654

else

4655

{ return $1;

4656

}

4657

}

4658

}

4659

100

if (wantarray)

4660

{ return ($buf, $offs, $siz, $embedded)

4661

}

4662

else

4663

{ return $buf;

4664

}

4665

}

4666

elsif (exists $unZipped{$nr})

4667

{ ;

4668

}

4669

elsif ($embedded)

4670

{ unZipPrepare($embedded);

4671

}

4672

if ($noEnd)

4673

{ if (wantarray)

4674

{ return ($unZipped{$nr}, $offs, $siz, $embedded)

4675

}

4676

else

4677

{ return $unZipped{$nr};

4678

}

4679

}

4680

else

4681

{ if (wantarray)

4682

{ return ("$unZipped{$nr}endobj\n", $offs, $siz, $embedded)

4683

}

4684

else

4685

{ return "$unZipped{$nr}endobj\n";

4686

}

4687

}

4688

}

4689

4690

sub getKnown

4691

{ my ($p, $nr) = @_;

4692

my ($del1, $del2);

4693

my @objData = @{$$$p[0]->{$nr}};

4694

if (defined $objData[oSTREAMP])

4695

{ sysseek INFIL, ($objData[oNR][0] + $objData[oPOS]), 0;

4696

sysread INFIL, $del1, ($objData[oSTREAMP] - $objData[oPOS]);

4697

sysread INFIL, $del2, ($objData[oNR][1] - $objData[oSTREAMP]);

4698

}

4699

else

4700

{ my $buf;

4701

my ($offs, $siz, $embedded) = @{$objData[oNR]};

4702

if ($offs)

4703

{ sysseek INFIL, $offs, 0;

4704

sysread INFIL, $buf, $siz;

4705

if ($buf =~ m/^\d+$ws+\d+$ws+obj$ws*(.*)/os)

4706

{ $del1 = $1;

4707

}

4708

}

4709

elsif (exists $unZipped{$nr})

4710

{ $del1 = "$unZipped{$nr} endobj";

4711

}

4712

elsif ($embedded)

4713

{ @objData = @{$$$p[0]->{$embedded}};

4714

unZipPrepare($embedded, $objData[oNR][0], $objData[oNR][1]);

4715

$del1 = "$unZipped{$nr} endobj";

4716

}

4717

}

4718

return (\$del1, \$del2, $objData[oKIDS], $objData[oTYPE]);

4719

}

4720

4721

4722

sub unZipPrepare

4723

{ my ($nr, $offs, $size) = @_;

4724

my $buf;

4725

if ($offs)

4726

{ sysseek INFIL, $offs, 0;

4727

sysread INFIL, $buf, $size;

4728

}

4729

else

4730

{ $buf = getObject($nr);

4731

}

4732

my (%param, $stream, $str);

4733

4734

if ($buf =~ m~^(\d+$ws+\d+$ws+obj$ws*<<[\w\d\/\s\[\]<>]+)stream\b~os)

4735

{ $str = $1;

4736

$offs = length($str) + 7;

4737

if (substr($buf, $offs, 1) eq "\n")

4738

{ $offs++;

4739

}

4740

4741

for (split('/',$str))

4742

{ if ($_ =~ m'^(\w+)(.*)'o)

4743

{ $param{$1} = $2 || ' ';

4744

}

4745

}

4746

$stream = substr($buf, $offs, $param{'Length'});

4747

my $x = inflateInit()

4748

|| die "Cannot create an inflation stream\n";

4749

my ($output, $status) = $x->inflate($stream);

4750

die "inflation failed\n"

4751

unless $status == 1;

4752

4753

my $first = $param{'First'};

4754

my @oOffsets = (substr($output, 0, $first) =~ m'(\d+)\b'osg);

4755

my $i = 0;

4756

my $j = 1;

4757

my $bytes;

4758

while ($oOffsets[$i])

4759

{ my $k = $j + 2;

4760

if ($oOffsets[$k])

4761

{ $bytes = $oOffsets[$k] - $oOffsets[$j];

4762

}

4763

else

4764

{ $bytes = length($output) - $first - $oOffsets[$j];

4765

}

4766

$unZipped{$oOffsets[$i]} = substr($output,($first + $oOffsets[$j]), $bytes);

4767

$i += 2;

4768

$j += 2;

4769

}

4770

}

4771

}

4772

4773

############################################

4774

# En definitionerna f�r en sida extraheras

4775

############################################

4776

4777

sub getPage

4778

{ my ($infil, $sidnr, $action) = @_;

4779

4780

my ($res, $i, $referens,$objNrSaved,$validStream, $formRes, @objData,

4781

@underObjekt, @sidObj, $strPos, $startSida, $sidor, $filId, $del1, $del2,

4782

$offs, $siz, $embedded, $vektor, $utrad, $robj, $valid, $Annots, $Names,

4783

$AcroForm, $AARoot, $AAPage);

4784

4785

my $sidAcc = 0;

4786

my $seq = 0;

4787

$imSeq = 0;

4788

@skapa = ();

4789

undef $formCont;

4790

4791

4792

$objNrSaved = $objNr;

4793

my $fSource = $infil . '_' . $sidnr;

4794

my $checkidOld = $checkId;

4795

($infil, $checkId) = findGet($infil, $checkidOld);

4796

if (($ldir) && ($checkId) && ($checkId ne $checkidOld))

4797

{ $log .= "Cid~$checkId\n";

4798

}

4799

$form{$fSource}[fID] = $checkId;

4800

$checkId = '';

4801

$behandlad{$infil}->{old} = {}

4802

unless (defined $behandlad{$infil}->{old});

4803

$processed{$infil}->{oldObject} = {}

4804

unless (defined $processed{$infil}->{oldObject});

4805

$processed{$infil}->{unZipped} = {}

4806

unless (defined $processed{$infil}->{unZipped});

4807

4808

if ($action eq 'print')

4809

{ *old = $behandlad{$infil}->{old};

4810

}

4811

else

4812

{ $behandlad{$infil}->{dummy} = {};

4813

*old = $behandlad{$infil}->{dummy};

4814

}

4815

4816

*oldObject = $processed{$infil}->{oldObject};

4817

*unZipped = $processed{$infil}->{unZipped};

4818

$root = (exists $processed{$infil}->{root})

4819

? $processed{$infil}->{root} : 0;

4820

4821

4822

my @stati = stat($infil);

4823

open (INFIL, "<$infil") || errLog("Couldn't open $infil, $!");

4824

binmode INFIL;

4825

4826

if (! $root)

4827

{ $root = xRefs($stati[7], $infil);

4828

}

4829

4830

#############

4831

# Hitta root

4832

#############

4833

4834

my $objektet = getObject($root);;

4835

4836

if ($sidnr == 1)

4837

{ if ($objektet =~ m|/AcroForm($ws+\d+$ws+\d+$ws+R)|so)

4838

{ $AcroForm = $1;

4839

}

4840

if ($objektet =~ m|/Names$ws+(\d+)$ws+\d+$ws+R|so)

4841

{ $Names = $1;

4842

}

4843

#################################################

4844

# Finns ett dictionary f�r Additional Actions ?

4845

#################################################

4846

if ($objektet =~ m|/AA$ws*\<\<$ws*[^\>]+[^\>]+|so) # AA �r ett dictionary

4847

{ my $k;

4848

my ($dummy, $obj) = split /\/AA/, $objektet;

4849

$obj =~ s/\<\

4850

$obj =~ s/\>\>/\>\>\#/gs;

4851

my @ord = split /\#/, $obj;

4852

for ($i = 0; $i <= $#ord; $i++)

4853

{ $AARoot .= $ord[$i];

4854

if ($ord[$i] =~ m'\S+'os)

4855

{ if ($ord[$i] =~ m'<<'os)

4856

{ $k++; }

4857

if ($ord[$i] =~ m'>>'os)

4858

{ $k--; }

4859

if ($k == 0)

4860

{ last; }

4861

}

4862

}

4863

}

4864

}

4865

4866

4867

# Hitta pages

4868

4869

4870

if ($objektet =~ m|/Pages$ws+(\d+)$ws+\d+$ws+R|os)

4871

{ $objektet = getObject($1);

4872

if ($objektet =~ m|/Count$ws+(\d+)|os)

4873

{ $sidor = $1;

4874

if ($sidnr <= $sidor)

4875

{ ($formRes, $valid) = kolla($objektet);

4876

}

4877

else

4878

{ return 0;

4879

}

4880

if ($sidor > 1)

4881

{ undef $AcroForm;

4882

undef $Names;

4883

undef $AARoot;

4884

if ($type eq 'docform')

4885

{ errLog("prDocForm can only be used for single page documents - try prDoc or reformat $infil");

4886

}

4887

}

4888

}

4889

}

4890

else

4891

{ errLog("Didn't find Pages in $infil - aborting"); }

4892

4893

if ($objektet =~ m|/Kids$ws*\[([^\]]+)|os)

4894

{ $vektor = $1; }

4895

while ($vektor =~ m|(\d+)$ws+\d+$ws+R|go)

4896

{ push @sidObj, $1;

4897

}

4898

4899

my $bryt1 = -20; # H�ngslen

4900

my $bryt2 = -20; # Sv�ngrem f�r att undvika o�ndliga loopar

4901

4902

while ($sidAcc < $sidnr)

4903

{ @underObjekt = @sidObj;

4904

@sidObj = ();

4905

$bryt1++;

4906

for my $uO (@underObjekt)

4907

{ $objektet = getObject($uO);

4908

if ($objektet =~ m|/Count$ws+(\d+)|os)

4909

{ if (($sidAcc + $1) < $sidnr)

4910

{ $sidAcc += $1; }

4911

else

4912

{ ($formRes, $valid) = kolla($objektet, $formRes);

4913

if ($objektet =~ m|/Kids$ws*\[([^\]]+)|os)

4914

{ $vektor = $1; }

4915

while ($vektor =~ m/(\d+)$ws+\d+$ws+R/gso)

4916

{ push @sidObj, $1; }

4917

last;

4918

}

4919

}

4920

else

4921

{ $sidAcc++; }

4922

if ($sidAcc == $sidnr)

4923

{ $seq = $uO;

4924

last; }

4925

$bryt2++;

4926

}

4927

if (($bryt1 > $sidnr) || ($bryt2 > $sidnr)) # Bryt o�ndliga loopar

4928

{ last; }

4929

}

4930

4931

($formRes, $validStream) = kolla($objektet, $formRes);

4932

$startSida = $seq;

4933

4934

if ($sidor == 1)

4935

{ #################################################

4936

# Kontrollera Page-objektet f�r annoteringar

4937

#################################################

4938

4939

if ($objektet =~ m|/Annots$ws*([^\/]+)|so)

4940

{ $Annots = $1;

4941

}

4942

#################################################

4943

# Finns ett dictionary f�r Additional Actions ?

4944

#################################################

4945

if ($objektet =~ m|/AA$ws*\<\<$ws*[^\>]+[^\>]+|so) # AA �r ett dictionary. Hela kopieras

4946

{ my $k;

4947

my ($dummy, $obj) = split /\/AA/, $objektet;

4948

$obj =~ s/\<\

4949

$obj =~ s/\>\>/\>\>\#/gs;

4950

my @ord = split /\#/, $obj;

4951

for ($i = 0; $i <= $#ord; $i++)

4952

{ $AAPage .= $ord[$i];

4953

if ($ord[$i] =~ m'\S+'s)

4954

{ if ($ord[$i] =~ m'<<'s)

4955

{ $k++; }

4956

if ($ord[$i] =~ m'>>'s)

4957

{ $k--; }

4958

if ($k == 0)

4959

{ last; }

4960

}

4961

}

4962

}

4963

}

4964

4965

my $rform = \$form{$fSource};

4966

@$$rform[fRESOURCE] = $formRes;

4967

my @BBox;

4968

if (defined $formBox[0])

4969

{ $BBox[0] = $formBox[0]; }

4970

else

4971

{ $BBox[0] = $genLowerX; }

4972

4973

if (defined $formBox[1])

4974

{ $BBox[1] = $formBox[1]; }

4975

else

4976

{ $BBox[1] = $genLowerY; }

4977

4978

if (defined $formBox[2])

4979

{ $BBox[2] = $formBox[2]; }

4980

else

4981

{ $BBox[2] = $genUpperX; }

4982

4983

if (defined $formBox[3])

4984

{ $BBox[3] = $formBox[3]; }

4985

else

4986

{ $BBox[3] = $genUpperY; }

4987

4988

@{$form{$fSource}[fBBOX]} = @BBox;

4989

4990

if ($formCont)

4991

{ $seq = $formCont;

4992

($objektet, $offs, $siz, $embedded) = getObject($seq);

4993

4994

$robj = \$$$rform[fOBJ]->{$seq};

4995

@{$$$robj[oNR]} = ($offs, $siz, $embedded);

4996

$$$robj[oFORM] = 'Y';

4997

$form{$fSource}[fMAIN] = $seq;

4998

if ($objektet =~ m/^(\d+$ws+\d+$ws+obj$ws*<<)(.+)(>>$ws*stream)/so)

4999

{ $del1 = $2;

5000

$strPos = length($1) + length($2) + length($3);

5001

$$$robj[oPOS] = length($1);

5002

$$$robj[oSTREAMP] = $strPos;

5003

my $nyDel1;

5004

$nyDel1 = '<

5005

$nyDel1 .= "/Resources $formRes" .

5006

"/BBox \[ $BBox[0] $BBox[1] $BBox[2] $BBox[3]\]" .

5007

# "/Matrix \[ 1 0 0 1 0 0 \]" .

5008

$del1;

5009

if ($action eq 'print')

5010

{ $objNr++;

5011

$objekt[$objNr] = $pos;

5012

}

5013

$referens = $objNr;

5014

5015

$res = ($nyDel1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs);

5016

if ($res)

5017

{ $$$robj[oKIDS] = 1; }

5018

if ($action eq 'print')

5019

{ $utrad = "$referens 0 obj\n" . "$nyDel1" . ">>\nstream";

5020

$del2 = substr($objektet, $strPos);

5021

$utrad .= $del2;

5022

$pos += syswrite UTFIL, $utrad;

5023

}

5024

$form{$fSource}[fVALID] = $validStream;

5025

}

5026

else # Endast resurserna kan behandlas

5027

{ $formRes =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5028

}

5029

}

5030

else # Endast resurserna kan behandlas

5031

{ $formRes =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5032

}

5033

5034

my $preLength;

5035

while (scalar @skapa)

5036

{ my @process = @skapa;

5037

@skapa = ();

5038

for (@process)

5039

{ my $Font;

5040

my $gammal = $$_[0];

5041

my $ny = $$_[1];

5042

($objektet, $offs, $siz, $embedded) = getObject($gammal);

5043

$robj = \$$$rform[fOBJ]->{$gammal};

5044

@{$$$robj[oNR]} = ($offs, $siz, $embedded);

5045

if($objektet =~ m/^(\d+$ws+\d+$ws+obj$ws*<<)(.+)(>>$ws*stream)/os)

5046

{ $del1 = $2;

5047

$strPos = length ($1) + length($2) + length($3);

5048

$$$robj[oPOS] = length($1);

5049

$$$robj[oSTREAMP] = $strPos;

5050

5051

######## En bild ########

5052

if ($del1 =~ m|/Subtype$ws*/Image|so)

5053

{ $imSeq++;

5054

$$$robj[oIMAGENR] = $imSeq;

5055

push @{$$$rform[fIMAGES]}, $gammal;

5056

5057

if ($del1 =~ m|/Width$ws+(\d+)|os)

5058

{ $$$robj[oWIDTH] = $1; }

5059

if ($del1 =~ m|/Height$ws+(\d+)|os)

5060

{ $$$robj[oHEIGHT] = $1; }

5061

}

5062

$res = ($del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs);

5063

if ($res)

5064

{ $$$robj[oKIDS] = 1; }

5065

if ($action eq 'print')

5066

{ $objekt[$ny] = $pos;

5067

$utrad = "$ny 0 obj\n<<" . "$del1" . '>>stream';

5068

$del2 = substr($objektet, $strPos);

5069

$utrad .= $del2;

5070

}

5071

}

5072

else

5073

{ if ($objektet =~ m|^(\d+$ws+\d+$ws+obj$ws*)|os)

5074

{ $preLength = length($1);

5075

$$$robj[oPOS] = $preLength;

5076

$objektet = substr($objektet, $preLength);

5077

}

5078

else

5079

{ $$$robj[oPOS] = 0;

5080

}

5081

$res = ($objektet =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs);

5082

100

if ($res)

5083

{ $$$robj[oKIDS] = 1; }

5084

if ($objektet =~ m|/Subtype$ws*/Image|so)

100

5085

{ $imSeq++;

5086

$$$robj[oIMAGENR] = $imSeq;

5087

push @{$$$rform[fIMAGES]}, $gammal;

5088

###################################

5089

# Sparar dimensionerna f�r bilden

5090

###################################

5091

if ($del1 =~ m|/Width$ws+(\d+)|os)

5092

{ $$$robj[oWIDTH] = $1; }

5093

5094

if ($del1 =~ m|/Height$ws+(\d+)|os)

5095

{ $$$robj[oHEIGHT] = $1; }

5096

}

5097

elsif ($objektet =~ m|/BaseFont$ws*/([^\s\/]+)|os)

5098

{ $Font = $1;

5099

$$$robj[oTYPE] = 'Font';

5100

$$$robj[oNAME] = $Font;

5101

if ((! exists $font{$Font})

5102

&& ($action))

5103

{ $fontNr++;

5104

$font{$Font}[foINTNAMN] = 'Ft' . $fontNr;

5105

$font{$Font}[foORIGINALNR] = $gammal;

5106

$fontSource{$Font}[foSOURCE] = $fSource;

5107

$fontSource{$Font}[foORIGINALNR] = $gammal;

5108

if ($objektet =~ m|/Subtype$ws*/Type0|os)

5109

{ $font{$Font}[foTYP] = 1;

5110

}

5111

if ($action eq 'print')

5112

{ $font{$Font}[foREFOBJ] = $ny;

5113

$objRef{'Ft' . $fontNr} = $ny;

5114

}

5115

}

5116

}

5117

5118

if ($action eq 'print')

5119

{ $objekt[$ny] = $pos;

5120

$utrad = "$ny 0 obj $objektet";

5121

}

5122

}

5123

if ($action eq 'print')

5124

{ $pos += syswrite UTFIL, $utrad;

5125

}

5126

}

5127

}

5128

5129

my $ref = \$form{$fSource};

5130

my @kids;

5131

my @nokids;

5132

5133

#################################################################

5134

# l�gg upp vektorer �ver vilka objekt som har KIDS eller NOKIDS

5135

#################################################################

5136

5137

for my $key (keys %{$$$ref[fOBJ]})

5138

{ $robj = \$$$ref[fOBJ]->{$key};

5139

100

if (! defined $$$robj[oFORM])

5140

100

{ if (defined $$$robj[oKIDS])

5141

{ push @kids, $key; }

5142

else

5143

{ push @nokids, $key; }

5144

}

5145

if ((defined $$$robj[0]->[2]) && (! exists $$$ref[fOBJ]->{$$$robj[0]->[2]}))

5146

{ $$$ref[fOBJ]->{$$$robj[0]->[2]}->[0] = $oldObject{$$$robj[0]->[2]};

5147

}

5148

}

5149

if (scalar @kids)

5150

{ $form{$fSource}[fKIDS] = \@kids;

5151

}

5152

if (scalar @nokids)

5153

{ $form{$fSource}[fNOKIDS] = \@nokids;

5154

}

5155

5156

if ($action ne 'print')

5157

{ $objNr = $objNrSaved; # Restore objNo if nothing was printed

5158

}

5159

5160

$behandlad{$infil}->{dummy} = {};

5161

*old = $behandlad{$infil}->{dummy};

5162

5163

$objNrSaved = $objNr; # Save objNo

5164

5165

if ($sidor == 1)

5166

{ @skapa = ();

5167

$old{$startSida} = $sidObjNr;

5168

my $ref = \$intAct{$fSource};

5169

@$$ref[iSTARTSIDA] = $startSida;

5170

if (defined $Names)

5171

{ @$$ref[iNAMES] = $Names;

5172

quickxform($Names);

5173

}

5174

if (defined $AcroForm)

5175

{ @$$ref[iACROFORM] = $AcroForm;

5176

$AcroForm =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5177

}

5178

if (defined $AARoot)

5179

{ @$$ref[iAAROOT] = $AARoot;

5180

$AARoot =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5181

}

5182

if (defined $AAPage)

5183

{ @$$ref[iAAPAGE] = $AAPage;

5184

$AAPage =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5185

}

5186

if (defined $Annots)

5187

{ my @array;

5188

if ($Annots =~ m'\[([^\[\]]*)\]'os)

5189

{ $Annots = $1;

5190

@array = ($Annots =~ m/\b(\d+)$ws+\d+$ws+R\b/ogs);

5191

}

5192

else

5193

{ if ($Annots =~ m/\b(\d+)$ws+\d+$ws+R\b/os)

5194

{ $Annots = getObject($1);

5195

@array = ($Annots =~ m/\b(\d+)$ws+\d+$ws+R\b/ogs);

5196

}

5197

}

5198

@$$ref[iANNOTS] = \@array;

5199

$Annots =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5200

}

5201

5202

while (scalar @skapa)

5203

{ my @process = @skapa;

5204

@skapa = ();

5205

for (@process)

5206

{ my $gammal = $$_[0];

5207

my $ny = $$_[1];

5208

($objektet, $offs, $siz, $embedded) = getObject($gammal);

5209

$robj = \$$$ref[fOBJ]->{$gammal};

5210

@{$$$robj[oNR]} = ($offs, $siz, $embedded);

5211

if ($objektet

5212

=~ m/^(\d+$ws+\d+$ws+obj$ws*<<)(.+)(>>$ws*stream)/os)

5213

{ $del1 = $2;

5214

$$$robj[oPOS] = length($1);

5215

$$$robj[oSTREAMP] = length($1) + length($2) + length($3);

5216

5217

$res = ($del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs);

5218

if ($res)

5219

{ $$$robj[oKIDS] = 1; }

5220

}

5221

else

5222

{ if ($objektet =~ m/^(\d+$ws+\d+$ws+obj)/os)

5223

{ my $preLength = length($1);

5224

$$$robj[oPOS] = $preLength;

5225

$objektet = substr($objektet, $preLength);

5226

5227

$res = ($objektet =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs);

5228

if ($res)

5229

{ $$$robj[oKIDS] = 1; }

5230

}

5231

}

5232

}

5233

}

5234

for my $key (keys %{$$$ref[fOBJ]})

5235

{ $robj = \$$$ref[fOBJ]->{$key};

5236

if ((defined $$$robj[0]->[2]) && (! exists $$$ref[fOBJ]->{$$$robj[0]->[2]}))

5237

{ $$$ref[fOBJ]->{$$$robj[0]->[2]}->[0] = $oldObject{$$$robj[0]->[2]};

5238

}

5239

}

5240

}

5241

5242

$objNr = $objNrSaved;

5243

$processed{$infil}->{root} = $root;

5244

close INFIL;

5245

return $referens;

5246

}

5247

5248

##################################################

5249

# �vers�tter ett gammalt objektnr till ett nytt

5250

# och sparar en tabell med vad som skall skapas

5251

##################################################

5252

5253

sub xform

5254

{ if (exists $old{$1})

5255

{ $old{$1};

5256

}

5257

else

5258

{ push @skapa, [$1, ++$objNr];

5259

$old{$1} = $objNr;

5260

}

5261

}

5262

5263

sub kolla

5264

{ #

5265

# Resurser

5266

5267

my $obj = shift;

5268

my $resources = shift;

5269

my $valid;

5270

5271

100

197

if ($obj =~ m/MediaBox$ws*\[$ws*([\-\.\d]+)$ws+([\-\.\d]+)$ws+([\-\.\d]+)$ws+([\-\.\d]+)/os)

5272

{ $formBox[0] = $1;

5273

$formBox[1] = $2;

5274

$formBox[2] = $3;

5275

$formBox[3] = $4;

5276

}

5277

5278

100

113

if ($obj =~ m|/Contents$ws+(\d+)|so)

5279

{ $formCont = $1;

5280

my $cObj = getObject($formCont, 1, 1);

5281

if ($cObj =~ m/^$ws*\[[^\]]+\]$ws*$/os)

5282

{ $valid = 0;

5283

undef $formCont;

5284

}

5285

else

5286

{ $valid = 1;

5287

}

5288

}

5289

elsif ($obj =~ m|/Contents$ws*\[$ws*(\d+)$ws+\d+$ws+R$ws*\]|so)

5290

{ $formCont = $1;

5291

$valid = 1;

5292

}

5293

5294

100

if ($obj =~ m'^(.+/Resources)'so)

5295

{ if ($obj =~ m/Resources($ws+\d+$ws+\d+$ws+R)/os) # H�nvisning

5296

{ $resources = $1; }

5297

else # Resurserna �r ett dictionary. Hela kopieras

5298

{ my $dummy;

5299

my $i;

5300

my $k;

5301

undef $resources;

5302

($dummy, $obj) = split /\/Resources/, $obj;

5303

$obj =~ s/\<\

5304

$obj =~ s/\>\>/\>\>\#/gs;

5305

my @ord = split /\#/, $obj;

5306

for ($i = 0; $i <= $#ord; $i++)

5307

{ $resources .= $ord[$i];

5308

if ($ord[$i] =~ m'\S+'s)

5309

{ if ($ord[$i] =~ m'<<'s)

5310

{ $k++; }

5311

if ($ord[$i] =~ m'>>'s)

5312

{ $k--; }

5313

if ($k == 0)

5314

{ last; }

5315

}

5316

}

5317

}

5318

}

5319

return ($resources, $valid);

5320

}

5321

5322

##############################

5323

# Ett formul�r (�ter)skapas

5324

##############################

5325

5326

sub byggForm

5327

{ no warnings;

20119

5328

my ($infil, $sidnr) = @_;

5329

5330

my ($res, $corr, $nyDel1, $formRes, $del1, $del2, $kids, $typ, $nr,

5331

$utrad);

5332

5333

my $fSource = $infil . '_' . $sidnr;

5334

my @stati = stat($infil);

5335

5336

$behandlad{$infil}->{old} = {}

5337

unless (defined $behandlad{$infil}->{old});

5338

$processed{$infil}->{oldObject} = {}

5339

unless (defined $processed{$infil}->{oldObject});

5340

$processed{$infil}->{unZipped} = {}

5341

unless (defined $processed{$infil}->{unZipped});

5342

5343

*old = $behandlad{$infil}->{old};

5344

*oldObject = $processed{$infil}->{oldObject};

5345

*unZipped = $processed{$infil}->{unZipped};

5346

5347

if ($form{$fSource}[fID] != $stati[9])

5348

{ errLog("$stati[9] ne $form{$fSource}[fID] aborts");

5349

}

5350

if ($checkId)

5351

{ if ($checkId ne $stati[9])

5352

{ my $mess = "$checkId \<\> $stati[9] \n"

5353

. "The Pdf-file $fSource has not the correct modification time. \n"

5354

. "The program is aborted";

5355

errLog($mess);

5356

}

5357

undef $checkId;

5358

}

5359

if ($ldir)

5360

{ $log .= "Cid~$stati[9]\n";

5361

}

5362

5363

open (INFIL, "<$infil") || errLog("The file $infil couldn't be opened, aborting $!");

5364

binmode INFIL;

5365

5366

####################################################

5367

# Objekt utan referenser kopieras och skrivs

5368

####################################################

5369

5370

for my $key (@{$form{$fSource}->[fNOKIDS]})

5371

{ if ((defined $old{$key}) && ($objekt[$old{$key}])) # already processed

5372

{ next;

5373

}

5374

5375

if (! defined $old{$key})

5376

{ $old{$key} = ++$objNr;

5377

}

5378

$nr = $old{$key};

5379

$objekt[$nr] = $pos;

5380

5381

($del1, $del2, $kids, $typ) = getKnown(\$form{$fSource},$key);

5382

5383

if ($typ eq 'Font')

5384

{ my $Font = ${$form{$fSource}}[0]->{$key}->[oNAME];

5385

if (! defined $font{$Font}[foINTNAMN])

5386

{ $fontNr++;

5387

$font{$Font}[foINTNAMN] = 'Ft' . $fontNr;

5388

$font{$Font}[foREFOBJ] = $nr;

5389

$objRef{'Ft' . $fontNr} = $nr;

5390

}

5391

}

5392

if (! defined $$del2)

5393

{ $utrad = "$nr 0 obj " . $$del1;

5394

}

5395

else

5396

{ $utrad = "$nr 0 obj\n<<" . $$del1 . $$del2;

5397

}

5398

$pos += syswrite UTFIL, $utrad;

5399

}

5400

5401

#######################################################

5402

# Objekt med referenser kopieras, behandlas och skrivs

5403

#######################################################

5404

for my $key (@{$form{$fSource}->[fKIDS]})

5405

{ if ((defined $old{$key}) && ($objekt[$old{$key}])) # already processed

5406

{ next;

5407

}

5408

5409

if (! defined $old{$key})

5410

{ $old{$key} = ++$objNr;

5411

}

5412

$nr = $old{$key};

5413

5414

$objekt[$nr] = $pos;

5415

5416

($del1, $del2, $kids, $typ) = getKnown(\$form{$fSource},$key);

5417

5418

$$del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/translate() . ' 0 R'/oegs;

5419

5420

if (defined $$del2)

5421

{ $utrad = "$nr 0 obj\n<<" . $$del1 . $$del2;

5422

}

5423

else

5424

{ $utrad = "$nr 0 obj " . $$del1;

5425

}

5426

5427

if (($typ) && ($typ eq 'Font'))

5428

{ my $Font = $form{$fSource}[0]->{$key}->[oNAME];

5429

if (! defined $font{$Font}[foINTNAMN])

5430

{ $fontNr++;

5431

$font{$Font}[foINTNAMN] = 'Ft' . $fontNr;

5432

$font{$Font}[foREFOBJ] = $nr;

5433

$objRef{'Ft' . $fontNr} = $nr;

5434

}

5435

}

5436

5437

$pos += syswrite UTFIL, $utrad;

5438

}

5439

5440

#################################

5441

# Formul�robjektet behandlas

5442

#################################

5443

5444

my $key = $form{$fSource}->[fMAIN];

5445

if (! defined $key)

5446

{ return undef;

5447

}

5448

5449

if (exists $old{$key}) # already processed

5450

{ close INFIL;

5451

return $old{$key};

5452

}

5453

5454

$nr = ++$objNr;

5455

5456

$objekt[$nr] = $pos;

5457

5458

$formRes = $form{$fSource}->[fRESOURCE];

5459

5460

($del1, $del2) = getKnown(\$form{$fSource}, $key);

5461

5462

$nyDel1 = '<

5463

$nyDel1 .= "/Resources $formRes" .

5464

'/BBox [' .

5465

$form{$fSource}->[fBBOX]->[0] . ' ' .

5466

$form{$fSource}->[fBBOX]->[1] . ' ' .

5467

$form{$fSource}->[fBBOX]->[2] . ' ' .

5468

$form{$fSource}->[fBBOX]->[3] . ' ]' .

5469

# "\]/Matrix \[ $sX 0 0 $sX $tX $tY \]" .

5470

$$del1;

5471

$nyDel1 =~ s/\b(\d+)$ws+\d+$ws+R\b/translate() . ' 0 R'/oegs;

5472

5473

$utrad = "$nr 0 obj" . $nyDel1 . $$del2;

5474

5475

$pos += syswrite UTFIL, $utrad;

5476

close INFIL;

5477

5478

return $nr;

5479

}

5480

5481

##################

5482

# En bild l�ses

5483

##################

5484

5485

sub getImage

5486

{ my ($infil, $sidnr, $bildnr, $key) = @_;

5487

if (! defined $key)

5488

{ errLog("Can't find image $bildnr on page $sidnr in file $infil, aborts");

5489

}

5490

5491

@skapa = ();

5492

my ($res, $corr, $nyDel1, $del1, $del2, $nr, $utrad);

5493

my $fSource = $infil . '_' . $sidnr;

5494

my $iSource = $fSource . '_' . $bildnr;

5495

5496

$behandlad{$infil}->{old} = {}

5497

unless (defined $behandlad{$infil}->{old});

5498

$processed{$infil}->{oldObject} = {}

5499

unless (defined $processed{$infil}->{oldObject});

5500

$processed{$infil}->{unZipped} = {}

5501

unless (defined $processed{$infil}->{unZipped});

5502

5503

*old = $behandlad{$infil}->{old};

5504

*oldObject = $processed{$infil}->{oldObject};

5505

*unZipped = $processed{$infil}->{unZipped};

5506

5507

my @stati = stat($infil);

5508

5509

if ($form{$fSource}[fID] != $stati[9])

5510

{ errLog("$stati[9] ne $form{$fSource}[fID], modification time has changed, aborting");

5511

}

5512

5513

if (exists $old{$key})

5514

{ return $old{$key};

5515

}

5516

5517

open (INFIL, "<$infil") || errLog("The file $infil couldn't be opened, $!");

5518

binmode INFIL;

5519

5520

#########################################################

5521

# En bild med referenser kopieras, behandlas och skrivs

5522

#########################################################

5523

5524

$nr = ++$objNr;

5525

$old{$key} = $nr;

5526

5527

$objekt[$nr] = $pos;

5528

5529

($del1, $del2) = getKnown(\$form{$fSource}, $key);

5530

5531

$$del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5532

if (defined $$del2)

5533

{ $utrad = "$nr 0 obj\n<<" . $$del1 . $$del2;

5534

}

5535

else

5536

{ $utrad = "$nr 0 obj " . $$del1;

5537

}

5538

$pos += syswrite UTFIL, $utrad;

5539

##################################

5540

# Skriv ut underordnade objekt

5541

##################################

5542

while (scalar @skapa)

5543

{ my @process = @skapa;

5544

@skapa = ();

5545

for (@process)

5546

{ my $gammal = $$_[0];

5547

my $ny = $$_[1];

5548

5549

($del1, $del2) = getKnown(\$form{$fSource}, $gammal);

5550

5551

$$del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5552

if (defined $$del2)

5553

{ $utrad = "$ny 0 obj\n<<" . $$del1 . $$del2;

5554

}

5555

else

5556

{ $utrad = "$ny 0 obj " . $$del1;

5557

}

5558

$objekt[$ny] = $pos;

5559

$pos += syswrite UTFIL, $utrad;

5560

}

5561

}

5562

5563

close INFIL;

5564

return $nr;

5565

5566

}

5567

5568

##############################################################

5569

# Interaktiva funktioner knutna till ett formul�r �terskapas

5570

##############################################################

5571

5572

sub AcroFormsEtc

5573

{ my ($infil, $sidnr) = @_;

5574

5575

my ($Names, $AARoot, $AAPage, $AcroForm);

5576

@skapa = ();

5577

5578

my ($res, $corr, $nyDel1, @objData, $del1, $del2, $utrad);

5579

my $fSource = $infil . '_' . $sidnr;

5580

5581

$behandlad{$infil}->{old} = {}

5582

unless (defined $behandlad{$infil}->{old});

5583

$processed{$infil}->{oldObject} = {}

5584

unless (defined $processed{$infil}->{oldObject});

5585

$processed{$infil}->{unZipped} = {}

5586

unless (defined $processed{$infil}->{unZipped});

5587

5588

*old = $behandlad{$infil}->{old};

5589

*oldObject = $processed{$infil}->{oldObject};

5590

*unZipped = $processed{$infil}->{unZipped};

5591

5592

my @stati = stat($infil);

5593

if ($form{$fSource}[fID] != $stati[9])

5594

{ print "$stati[9] ne $form{$fSource}[fID]\n";

5595

errLog("Modification time for $fSource has changed, aborting");

5596

}

5597

5598

open (INFIL, "<$infil") || errLog("The file $infil couldn't be opened, aborting $!");

5599

binmode INFIL;

5600

5601

my $fdSidnr = $intAct{$fSource}[iSTARTSIDA];

5602

$old{$fdSidnr} = $sidObjNr;

5603

5604

if (($intAct{$fSource}[iNAMES]) ||(scalar @jsfiler) || (scalar @inits) || (scalar %fields))

5605

{ $Names = behandlaNames($intAct{$fSource}[iNAMES], $fSource);

5606

}

5607

5608

##################################

5609

# Referenser behandlas och skrivs

5610

##################################

5611

5612

if (defined $intAct{$fSource}[iACROFORM])

5613

{ $AcroForm = $intAct{$fSource}[iACROFORM];

5614

$AcroForm =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5615

}

5616

if (defined $intAct{$fSource}[iAAROOT])

5617

{ $AARoot = $intAct{$fSource}[iAAROOT];

5618

$AARoot =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5619

}

5620

5621

if (defined $intAct{$fSource}[iAAPAGE])

5622

{ $AAPage = $intAct{$fSource}[iAAPAGE];

5623

$AAPage =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5624

}

5625

if (defined $intAct{$fSource}[iANNOTS])

5626

{ for (@{$intAct{$fSource}[iANNOTS]})

5627

{ push @annots, quickxform($_);

5628

}

5629

}

5630

5631

##################################

5632

# Skriv ut underordnade objekt

5633

##################################

5634

while (scalar @skapa)

5635

{ my @process = @skapa;

5636

@skapa = ();

5637

for (@process)

5638

{ my $gammal = $$_[0];

5639

my $ny = $$_[1];

5640

5641

my $oD = \@{$intAct{$fSource}[0]->{$gammal}};

5642

@objData = @{$$oD[oNR]};

5643

5644

if (defined $$oD[oSTREAMP])

5645

{ $res = sysseek INFIL, ($objData[0] + $$oD[oPOS]), 0;

5646

$corr = sysread INFIL, $del1, ($$oD[oSTREAMP] - $$oD[oPOS]) ;

5647

if (defined $$oD[oKIDS])

5648

{ $del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5649

}

5650

$res = sysread INFIL, $del2, ($objData[1] - $corr);

5651

$utrad = "$ny 0 obj\n<<" . $del1 . $del2;

5652

}

5653

else

5654

{ $del1 = getObject($gammal);

5655

$del1 = substr($del1, $$oD[oPOS]);

5656

if (defined $$oD[oKIDS])

5657

{ $del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5658

}

5659

$utrad = "$ny 0 obj " . $del1;

5660

}

5661

5662

$objekt[$ny] = $pos;

5663

$pos += syswrite UTFIL, $utrad;

5664

}

5665

}

5666

5667

close INFIL;

5668

return ($Names, $AARoot, $AAPage, $AcroForm);

5669

}

5670

5671

##############################

5672

# Ett namnobjekt extraheras

5673

##############################

5674

5675

sub extractName

5676

{ my ($infil, $sidnr, $namn) = @_;

5677

5678

my ($res, $del1, $resType, $key, $corr, $formRes, $kids, $nr, $utrad);

5679

my $del2 = '';

5680

@skapa = ();

5681

5682

$behandlad{$infil}->{old} = {}

5683

unless (defined $behandlad{$infil}->{old});

5684

$processed{$infil}->{oldObject} = {}

5685

unless (defined $processed{$infil}->{oldObject});

5686

$processed{$infil}->{unZipped} = {}

5687

unless (defined $processed{$infil}->{unZipped});

5688

5689

*old = $behandlad{$infil}->{old};

5690

*oldObject = $processed{$infil}->{oldObject};

5691

*unZipped = $processed{$infil}->{unZipped};

5692

5693

my $fSource = $infil . '_' . $sidnr;

5694

5695

my @stati = stat($infil);

5696

5697

if ($form{$fSource}[fID] != $stati[9])

5698

{ errLog("$stati[9] ne $form{$fSource}[fID] aborts");

5699

}

5700

if ($checkId)

5701

{ if ($checkId ne $stati[9])

5702

{ my $mess = "$checkId \<\> $stati[9] \n"

5703

. "The Pdf-file $fSource has not the correct modification time. \n"

5704

. "The program is aborted";

5705

errLog($mess);

5706

}

5707

undef $checkId;

5708

}

5709

if ($ldir)

5710

{ $log .= "Cid~$stati[9]\n";

5711

}

5712

5713

open (INFIL, "<$infil") || errLog("The file $infil couldn't be opened, aborting $!");

5714

binmode INFIL;

5715

5716

#################################

5717

# Resurserna l�ses

5718

#################################

5719

5720

$formRes = $form{$fSource}->[fRESOURCE];

5721

5722

if ($formRes !~ m'<<.*>>'os) # If not a directory, get it

5723

{ if ($formRes =~ m/\b(\d+)$ws+\d+$ws+R/o)

5724

{ $key = $1;

5725

$formRes = getKnown(\$form{$fSource}, $key);

5726

}

5727

else

5728

{ return undef;

5729

}

5730

}

5731

undef $key;

5732

while ($formRes =~ m|\/(\w+)$ws*\<\<([^>]+)\>\>|osg)

5733

{ $resType = $1;

5734

my $str = $2;

5735

if ($str =~ m|$namn$ws+(\d+)$ws+\d+$ws+R|s)

5736

{ $key = $1;

5737

last;

5738

}

5739

}

5740

if (! defined $key) # Try to expand the references

5741

{ my ($str, $del1, $del2);

5742

while ($formRes =~ m|(\/\w+)$ws+(\d+)$ws+\d+$ws+R|ogs)

5743

{ $str .= $1 . ' ';

5744

($del1, $del2) = getKnown(\$form{$fSource}, $2);

5745

my $string = $$del1;

5746

$str .= $string . ' ';

5747

}

5748

$formRes = $str;

5749

while ($formRes =~ m|\/(\w+)$ws*\<\<([^>]+)\>\>|osg)

5750

{ $resType = $1;

5751

my $str = $2;

5752

if ($str =~ m|$namn$ws+(\d+)$ws+\d+$ws+R|s)

5753

{ $key = $1;

5754

last;

5755

}

5756

}

5757

return undef unless $key;

5758

}

5759

5760

########################################

5761

# Read the top object of the hierarchy

5762

########################################

5763

5764

($del1, $del2) = getKnown(\$form{$fSource}, $key);

5765

5766

$objNr++;

5767

$nr = $objNr;

5768

5769

if ($resType eq 'Font')

5770

{ my ($Font, $extNamn);

5771

if ($$del1 =~ m|/BaseFont$ws*/([^\s\/]+)|os)

5772

{ $extNamn = $1;

5773

if (! exists $font{$extNamn})

5774

{ $fontNr++;

5775

$Font = 'Ft' . $fontNr;

5776

$font{$extNamn}[foINTNAMN] = $Font;

5777

$font{$extNamn}[foORIGINALNR] = $nr;

5778

if ($del1 =~ m|/Subtype$ws*/Type0|os)

5779

{ $font{$extNamn}[foTYP] = 1;

5780

}

5781

$fontSource{$Font}[foSOURCE] = $fSource;

5782

$fontSource{$Font}[foORIGINALNR] = $nr;

5783

}

5784

$font{$extNamn}[foREFOBJ] = $nr;

5785

$Font = $font{$extNamn}[foINTNAMN];

5786

$namn = $Font;

5787

$objRef{$Font} = $nr;

5788

}

5789

else

5790

{ errLog("Inconsitency in $fSource, font $namn can't be found, aborting");

5791

}

5792

}

5793

elsif ($resType eq 'ColorSpace')

5794

{ $colorSpace++;

5795

$namn = 'Cs' . $colorSpace;

5796

$objRef{$namn} = $nr;

5797

}

5798

elsif ($resType eq 'Pattern')

5799

{ $pattern++;

5800

$namn = 'Pt' . $pattern;

5801

$objRef{$namn} = $nr;

5802

}

5803

elsif ($resType eq 'Shading')

5804

{ $shading++;

5805

$namn = 'Sh' . $shading;

5806

$objRef{$namn} = $nr;

5807

}

5808

elsif ($resType eq 'ExtGState')

5809

{ $gSNr++;

5810

$namn = 'Gs' . $gSNr;

5811

$objRef{$namn} = $nr;

5812

}

5813

elsif ($resType eq 'XObject')

5814

{ if (defined $form{$fSource}->[0]->{$nr}->[oIMAGENR])

5815

{ $namn = 'Ig' . $form{$fSource}->[0]->{$nr}->[oIMAGENR];

5816

}

5817

else

5818

{ $formNr++;

5819

$namn = 'Fo' . $formNr;

5820

}

5821

5822

$objRef{$namn} = $nr;

5823

}

5824

5825

$$del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

5826

5827

if (defined $$del2)

5828

{ $utrad = "$nr 0 obj\n<<" . $$del1 . $$del2;

5829

}

5830

else

5831

{ $utrad = "$nr 0 obj " . $$del1;

5832

}

5833

$objekt[$nr] = $pos;

5834

$pos += syswrite UTFIL, $utrad;

5835

5836

##################################

5837

# Skriv ut underordnade objekt

5838

##################################

5839

5840

while (scalar @skapa)

5841

{ my @process = @skapa;

5842

@skapa = ();

5843

for (@process)

5844

{ my $gammal = $$_[0];

5845

my $ny = $$_[1];

5846

5847

($del1, $del2, $kids) = getKnown(\$form{$fSource}, $gammal);

5848

5849

$$del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs

5850

unless (! defined $kids);

5851

if (defined $$del2)

5852

{ $utrad = "$ny 0 obj\n<<" . $$del1 . $$del2;

5853

}

5854

else

5855

{ $utrad = "$ny 0 obj " . $$del1;

5856

}

5857

$objekt[$ny] = $pos;

5858

$pos += syswrite UTFIL, $utrad;

5859

}

5860

}

5861

close INFIL;

5862

5863

return $namn;

5864

5865

}

5866

5867

########################

5868

# Ett objekt extraheras

5869

########################

5870

5871

sub extractObject

5872

{ no warnings;

50762

5873

my ($infil, $sidnr, $key, $typ) = @_;

5874

5875

my ($res, $del1, $corr, $namn, $kids, $nr, $utrad);

5876

my $del2 = '';

5877

@skapa = ();

5878

5879

$behandlad{$infil}->{old} = {}

5880

unless (defined $behandlad{$infil}->{old});

5881

$processed{$infil}->{oldObject} = {}

5882

unless (defined $processed{$infil}->{oldObject});

5883

$processed{$infil}->{unZipped} = {}

5884

unless (defined $processed{$infil}->{unZipped});

5885

5886

*old = $behandlad{$infil}->{old};

5887

*oldObject = $processed{$infil}->{oldObject};

5888

*unZipped = $processed{$infil}->{unZipped};

5889

5890

my $fSource = $infil . '_' . $sidnr;

5891

my @stati = stat($infil);

5892

5893

if ($form{$fSource}[fID] != $stati[9])

5894

{ errLog("$stati[9] ne $form{$fSource}[fID] aborts");

5895

}

5896

if ($checkId)

5897

{ if ($checkId ne $stati[9])

5898

{ my $mess = "$checkId \<\> $stati[9] \n"

5899

. "The Pdf-file $fSource has not the correct modification time. \n"

5900

. "The program is aborted";

5901

errLog($mess);

5902

}

5903

undef $checkId;

5904

}

5905

if ($ldir)

5906

{ $log .= "Cid~$stati[9]\n";

5907

my $indata = prep($infil);

5908

$log .= "Form~$indata~$sidnr~~load~1\n";

5909

}

5910

5911

open (INFIL, "<$infil") || errLog("The file $infil couldn't be opened, aborting $!");

5912

binmode INFIL;

5913

5914

########################################

5915

# Read the top object of the hierarchy

5916

########################################

5917

5918

($del1, $del2, $kids) = getKnown(\$form{$fSource}, $key);

5919

5920

if (exists $old{$key})

5921

{ $nr = $old{$key}; }

5922

else

5923

{ $old{$key} = ++$objNr;

5924

$nr = $objNr;

5925

}

5926

5927

if ($typ eq 'Font')

5928

{ my ($Font, $extNamn);

5929

if ($$del1 =~ m|/BaseFont$ws*/([^\s\/]+)|os)

5930

{ $extNamn = $1;

5931

$fontNr++;

5932

$Font = 'Ft' . $fontNr;

5933

$font{$extNamn}[foINTNAMN] = $Font;

5934

$font{$extNamn}[foORIGINALNR] = $key;

5935

if ($del1 =~ m|/Subtype$ws*/Type0|os)

5936

{ $font{$extNamn}[foTYP] = 1;

5937

}

5938

if ( ! defined $fontSource{$extNamn}[foSOURCE])

5939

{ $fontSource{$extNamn}[foSOURCE] = $fSource;

5940

$fontSource{$extNamn}[foORIGINALNR] = $key;

5941

}

5942

$font{$extNamn}[foREFOBJ] = $nr;

5943

$Font = $font{$extNamn}[foINTNAMN];

5944

$namn = $Font;

5945

$objRef{$Font} = $nr;

5946

}

5947

else

5948

{ errLog("Error in $fSource, $key is not a font, aborting");

5949

}

5950

}

5951

elsif ($typ eq 'ColorSpace')

5952

{ $colorSpace++;

5953

$namn = 'Cs' . $colorSpace;

5954

$objRef{$namn} = $nr;

5955

}

5956

elsif ($typ eq 'Pattern')

5957

{ $pattern++;

5958

$namn = 'Pt' . $pattern;

5959

$objRef{$namn} = $nr;

5960

}

5961

elsif ($typ eq 'Shading')

5962

{ $shading++;

5963

$namn = 'Sh' . $shading;

5964

$objRef{$namn} = $nr;

5965

}

5966

elsif ($typ eq 'ExtGState')

5967

{ $gSNr++;

5968

$namn = 'Gs' . $gSNr;

5969

$objRef{$namn} = $nr;

5970

}

5971

elsif ($typ eq 'XObject')

5972

{ if (defined $form{$fSource}->[0]->{$nr}->[oIMAGENR])

5973

{ $namn = 'Ig' . $form{$fSource}->[0]->{$nr}->[oIMAGENR];

5974

}

5975

else

5976

{ $formNr++;

5977

$namn = 'Fo' . $formNr;

5978

}

5979

5980

$objRef{$namn} = $nr;

5981

}

5982

5983

$$del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs

5984

unless (! defined $kids);

5985

if (defined $$del2)

5986

{ $utrad = "$nr 0 obj\n<<" . $$del1 . $$del2;

5987

}

5988

else

5989

{ $utrad = "$nr 0 obj " . $$del1;

5990

}

5991

5992

$objekt[$nr] = $pos;

5993

$pos += syswrite UTFIL, $utrad;

5994

5995

##################################

5996

# Skriv ut underordnade objekt

5997

##################################

5998

5999

while (scalar @skapa)

6000

{ my @process = @skapa;

6001

@skapa = ();

6002

for (@process)

6003

{ my $gammal = $$_[0];

6004

my $ny = $$_[1];

6005

6006

($del1, $del2, $kids) = getKnown(\$form{$fSource}, $gammal);

6007

6008

$$del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs

6009

unless (! defined $kids);

6010

6011

if (defined $$del2)

6012

{ $utrad = "$ny 0 obj<<" . $$del1 . $$del2;

6013

}

6014

else

6015

{ $utrad = "$ny 0 obj " . $$del1;

6016

}

6017

6018

$objekt[$ny] = $pos;

6019

$pos += syswrite UTFIL, $utrad;

6020

}

6021

}

6022

close INFIL;

6023

return $namn;

6024

}

6025

6026

6027

##########################################

6028

# En fil analyseras och sidorna kopieras

6029

##########################################

6030

6031

sub analysera

6032

{ my $infil = shift;

6033

my $from = shift || 1;

6034

my $to = shift || 0;

6035

my $singlePage = shift;

6036

my ($i, $res, @underObjekt, @sidObj, $vektor, $resources, $valid,

6037

$strPos, $sidor, $filId, $Root, $del1, $del2, $utrad);

6038

6039

my $extraherade = 0;

6040

my $sidAcc = 0;

6041

@skapa = ();

6042

6043

$behandlad{$infil}->{old} = {}

6044

unless (defined $behandlad{$infil}->{old});

6045

$processed{$infil}->{oldObject} = {}

6046

unless (defined $processed{$infil}->{oldObject});

6047

$processed{$infil}->{unZipped} = {}

6048

unless (defined $processed{$infil}->{unZipped});

6049

*old = $behandlad{$infil}->{old};

6050

*oldObject = $processed{$infil}->{oldObject};

6051

*unZipped = $processed{$infil}->{unZipped};

6052

6053

$root = (exists $processed{$infil}->{root})

6054

? $processed{$infil}->{root} : 0;

6055

6056

my ($AcroForm, $Annots, $Names, $AARoot);

6057

undef $taInterAkt;

6058

undef %script;

6059

6060

my $checkIdOld = $checkId;

6061

($infil, $checkId) = findGet($infil, $checkIdOld);

6062

if (($ldir) && ($checkId) && ($checkId ne $checkIdOld))

6063

{ $log .= "Cid~$checkId\n";

6064

}

6065

undef $checkId;

6066

my @stati = stat($infil);

6067

open (INFIL, "<$infil") || errLog("Couldn't open $infil,aborting. $!");

6068

binmode INFIL;

6069

6070

if (! $root)

6071

{ $root = xRefs($stati[7], $infil);

6072

}

6073

#############

6074

# Hitta root

6075

#############

6076

6077

my $offSet;

6078

my $bytes;

6079

my $objektet = getObject($root);

6080

6081

if ((! $interActive) && ( ! $to) && ($from == 1))

6082

{ if ($objektet =~ m|/AcroForm($ws+\d+$ws+\d+$ws+R)|so)

6083

{ $AcroForm = $1;

6084

}

6085

if ($objektet =~ m|/Names$ws+(\d+)$ws+\d+$ws+R|so)

6086

{ $Names = $1;

6087

}

6088

if ((scalar %fields) || (scalar @jsfiler) || (scalar @inits))

6089

{ $Names = behandlaNames($Names);

6090

}

6091

elsif ($Names)

6092

{ $Names = quickxform($Names);

6093

}

6094

6095

#################################################

6096

# Finns ett dictionary f�r Additional Actions ?

6097

#################################################

6098

if ($objektet =~ m|/AA($ws+\d+$ws+\d+$ws+R)|os) # H�nvisning

6099

{ $AARoot = $1; }

6100

elsif ($objektet =~ m|/AA$ws*\<\<$ws*[^\>]+[^\>]+|so) # AA �r ett dictionary

6101

{ my $k;

6102

my ($dummy, $obj) = split /\/AA/, $objektet;

6103

$obj =~ s/\<\

6104

$obj =~ s/\>\>/\>\>\#/gs;

6105

my @ord = split /\#/, $obj;

6106

for ($i = 0; $i <= $#ord; $i++)

6107

{ $AARoot .= $ord[$i];

6108

if ($ord[$i] =~ m'\S+'os)

6109

{ if ($ord[$i] =~ m'<<'os)

6110

{ $k++; }

6111

if ($ord[$i] =~ m'>>'os)

6112

{ $k--; }

6113

if ($k == 0)

6114

{ last; }

6115

}

6116

}

6117

}

6118

$taInterAkt = 1; # Flagga att ta med interaktiva funktioner

6119

}

6120

6121

6122

# Hitta pages

6123

6124

6125

if ($objektet =~ m|/Pages$ws+(\d+)$ws+\d+$ws+R|os)

6126

{ $objektet = getObject($1);

6127

$resources = checkResources($objektet, $resources);

6128

if ($objektet =~ m|/Count$ws+(\d+)|os)

6129

{ $sidor = $1;

6130

$behandlad{$infil}->{sidor} = $sidor;

6131

}

6132

}

6133

else

6134

{ errLog("Didn't find pages "); }

6135

6136

my @levels; my %kids;

6137

my $li = -1;

6138

6139

if ($objektet =~ m|/Kids$ws*\[([^\]]+)|os)

6140

{ $vektor = $1;

6141

while ($vektor =~ m|(\d+)$ws+\d+$ws+R|go)

6142

{ push @sidObj, $1;

6143

}

6144

$li++;

6145

$levels[$li] = \@sidObj;

6146

}

6147

6148

while (($li > -1) && ($sidAcc < $sidor))

6149

{ if (scalar @{$levels[$li]})

6150

{ my $j = shift @{$levels[$li]};

6151

$objektet = getObject($j);

6152

if ($objektet =~ m|/Kids$ws*\[([^\]]+)|os)

6153

{ $resources = checkResources($objektet, $resources);

6154

$vektor = $1;

6155

my @sObj;

6156

while ($vektor =~ m/(\d+)$ws+\d+$ws+R/go)

6157

{ push @sObj, $1 if !$kids{$1}; $kids{$1}=1;

6158

}

6159

if(@sObj)

6160

{ $li++;

6161

$levels[$li] = \@sObj;

6162

}

6163

}

6164

else

6165

{ $sidAcc++;

6166

if ($sidAcc >= $from)

6167

{ if ($to)

6168

{ if ($sidAcc <= $to)

6169

{ sidAnalys($j, $objektet, $resources);

6170

$extraherade++;

6171

$sida++;

6172

}

6173

else

6174

{ $sidAcc = $sidor;

6175

}

6176

}

6177

else

6178

{ sidAnalys($j, $objektet, $resources);

6179

$extraherade++;

6180

$sida++;

6181

}

6182

}

6183

}

6184

}

6185

else

6186

{ $li--;

6187

}

6188

}

6189

6190

if (defined $AcroForm)

6191

{ $AcroForm =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

6192

}

6193

if (defined $AARoot)

6194

{ $AARoot =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

6195

}

6196

6197

while (scalar @skapa)

6198

{ my @process = @skapa;

6199

@skapa = ();

6200

for (@process)

6201

{ my $gammal = $$_[0];

6202

my $ny = $$_[1];

6203

$objektet = getObject($gammal);

6204

6205

if($objektet =~ m/^(\d+$ws+\d+$ws+obj$ws*<<)(.+)(>>$ws*stream)/os)

6206

{ $del1 = $2;

6207

$strPos = length($2) + length($3) + length($1);

6208

$del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

6209

$objekt[$ny] = $pos;

6210

$utrad = "$ny 0 obj<<" . "$del1" . '>>stream';

6211

$del2 = substr($objektet, $strPos);

6212

$utrad .= $del2;

6213

6214

$pos += syswrite UTFIL, $utrad;

6215

}

6216

else

6217

{ if ($objektet =~ m/^(\d+$ws+\d+$ws+obj)/os)

6218

{ my $preLength = length($1);

6219

$objektet = substr($objektet, $preLength);

6220

}

6221

$objektet =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

6222

$objekt[$ny] = $pos;

6223

$utrad = "$ny 0 obj$objektet";

6224

$pos += syswrite UTFIL, $utrad;

6225

}

6226

}

6227

}

6228

close INFIL;

6229

$processed{$infil}->{root} = $root;

6230

6231

if (! $singlePage)

6232

{ return ($extraherade, $Names, $AARoot, $AcroForm);

6233

}

6234

else

6235

{ if ($extraherade)

6236

{ my $kvar = $behandlad{$infil}->{sidor} - $from;

6237

return ($kvar, $Names, $AARoot, $AcroForm);

6238

}

6239

else

6240

{ return (undef, undef, undef, undef);

6241

}

6242

}

6243

}

6244

6245

sub sidAnalys

6246

{ my ($oNr, $obj, $resources) = @_;

6247

my ($ny, $strPos, $spar, $closeProc, $del1, $del2, $utrad, $Annots,

6248

$resursObjekt, $streamObjekt, @extObj, $langd);

6249

6250

if ((defined $stream) && (length($stream) > 0))

6251

{

6252

if ($checkCs)

6253

{ @extObj = ($stream =~ m'/(\S+)\s*'gso);

6254

checkContentStream(@extObj);

6255

}

6256

6257

$objNr++;

6258

$objekt[$objNr] = $pos;

6259

6260

if (( $compress ) && ( length($stream) > 99 ))

6261

{ my $output = compress($stream);

6262

if ((length($output) > 25) && (length($output) < (length($stream))))

6263

{ $stream = $output;

6264

}

6265

$langd = length($stream);

6266

$stream = "\n" . $stream . "\n";

6267

$langd++;

6268

$streamObjekt = "$objNr 0 obj<

6269

. "/Length $langd>>stream" . $stream;

6270

$streamObjekt .= "endstream\nendobj\n";

6271

6272

}

6273

else

6274

{ $langd = length($stream);

6275

$streamObjekt = "$objNr 0 obj<>stream\n" . $stream;

6276

$streamObjekt .= "\nendstream\nendobj\n";

6277

}

6278

$pos += syswrite UTFIL, $streamObjekt;

6279

$streamObjekt = "$objNr 0 R ";

6280

6281

########################################################################

6282

# Sometimes the contents reference is a ref to an object which

6283

# contains an array of content streams. Replace the ref with the array

6284

########################################################################

6285

6286

if ($obj =~ m|/Contents$ws+(\d+)$ws+\d+$ws+R|os)

6287

{ my $cObj = getObject($1, 1, 1);

6288

if ($cObj =~ m/^$ws*\[[^\]]+\]$ws*$/os)

6289

{ $obj =~ s|/Contents$ws+\d+$ws+\d+$ws+R|'/Contents ' . $cObj|oes;

6290

}

6291

}

6292

6293

my ($from, $to);

6294

6295

($resources, $from, $to) = checkResources ($obj, $resources);

6296

if ($from && $to)

6297

{ $obj = substr($obj, 0, $from) . substr($obj, $to);

6298

}

6299

6300

6301

##########################

6302

# Hitta resursdictionary

6303

##########################

6304

my $i = 0;

6305

while (($resources !~ m'\/'os) && ($i < 10))

6306

{ $i++;

6307

if ($resources =~ m/$ws+(\d+)$ws+\d+$ws+R/os)

6308

{ $resources = getObject($1, 1, 1);

6309

}

6310

}

6311

if ($i > 7)

6312

{ errLog("Couldn't find resources to merge");

6313

}

6314

if ($resources =~ m/$ws*\<\<(.*)\>\>/os)

6315

{ $resources = $1;

6316

}

6317

6318

if ($resources !~ m'/ProcSet')

6319

{ $resources = '/ProcSet[/PDF/Text] ' . $resources;

6320

}

6321

6322

###############################################################

6323

# L�sa ev. referenser och skapa ett resursobjekt best�ende av

6324

# dictionaries (f�r utvalda resurser)

6325

###############################################################

6326

6327

if (scalar %sidFont)

6328

{ if ($resources =~ m|/Font$ws+(\d+)$ws+\d+$ws+R|os)

6329

{ my $dict = getObject($1, 1, 1);

6330

$resources =~ s"/Font$ws+\d+$ws+\d+$ws+R"'/Font' . $dict"ose;

6331

}

6332

}

6333

6334

if (scalar %sidXObject)

6335

{ if ($resources =~ m|/XObject$ws+(\d+)$ws+\d+$ws+R|os)

6336

{ my $dict = getObject($1, 1, 1);

6337

$resources =~ s"/XObject$ws+\d+$ws+\d+$ws+R"'/XObject' . $dict"ose;

6338

}

6339

}

6340

6341

if (scalar %sidExtGState)

6342

{ if ($resources =~ m|/ExtGState$ws+(\d+)$ws+\d+$ws+R|os)

6343

{ my $dict = getObject($1, 1, 1);

6344

$resources =~ s"/ExtGState$ws+\d+$ws+\d+$ws+R"'/ExtGState' . $dict"ose;

6345

}

6346

}

6347

6348

if (scalar %sidPattern)

6349

{ if ($resources =~ m|/Pattern$ws+(\d+)$ws+\d+$ws+R|os)

6350

{ my $dict = getObject($1, 1, 1);

6351

$resources =~ s"/Pattern$ws+\d+$ws+\d+$ws+R"'/Pattern' . $dict"ose;

6352

}

6353

}

6354

6355

if (scalar %sidShading)

6356

{ if ($resources =~ m|/Shading$ws+(\d+)$ws+\d+$ws+R|os)

6357

{ my $dict = getObject($1, 1, 1);

6358

$resources =~ s"/Shading$ws+\d+$ws+\d+$ws+R"'/Shading' . $dict"ose;

6359

}

6360

}

6361

6362

if (scalar %sidColorSpace)

6363

{ if ($resources =~ m|/ColorSpace$ws+(\d+)$ws+\d+$ws+R|os)

6364

{ my $dict = getObject($1, 1, 1);

6365

$resources =~ s"/ColorSpace$ws+\d+$ws+\d+$ws+R"'/ColorSpace' . $dict"ose;

6366

}

6367

}

6368

####################################################

6369

# Nu �r resurserna "normaliserade" med ursprungliga

6370

# v�rden. Spara v�rden f�r "�vers�ttning"

6371

####################################################

6372

6373

$resources =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

6374

6375

###############################

6376

# Komplettera med nya resurser

6377

###############################

6378

6379

if (scalar %sidFont)

6380

{ my $str = '';

6381

for (sort keys %sidFont)

6382

{ $str .= "/$_ $sidFont{$_} 0 R";

6383

}

6384

if ($resources !~ m'\/Font'os)

6385

{ $resources = "/Font << $str >> " . $resources;

6386

}

6387

else

6388

{ $resources =~ s"/Font$ws*<<"'/Font<<' . $str"oges;

6389

}

6390

}

6391

6392

if (scalar %sidXObject)

6393

{ my $str = '';

6394

for (sort keys %sidXObject)

6395

{ $str .= "/$_ $sidXObject{$_} 0 R";

6396

}

6397

if ($resources !~ m'\/XObject'os)

6398

{ $resources = "/XObject << $str >> " . $resources;

6399

}

6400

else

6401

{ $resources =~ s"/XObject$ws*<<"'/XObject<<' . $str"oges;

6402

}

6403

}

6404

6405

if (scalar %sidExtGState)

6406

{ my $str = '';

6407

for (sort keys %sidExtGState)

6408

{ $str .= "/$_ $sidExtGState{$_} 0 R";

6409

}

6410

if ($resources !~ m'\/ExtGState'os)

6411

{ $resources = "/ExtGState << $str >> " . $resources;

6412

}

6413

else

6414

{ $resources =~ s"/ExtGState$ws*<<"'/ExtGState<<' . $str"oges;

6415

}

6416

}

6417

6418

if (scalar %sidPattern)

6419

{ my $str = '';

6420

for (sort keys %sidPattern)

6421

{ $str .= "/$_ $sidPattern{$_} 0 R";

6422

}

6423

if ($resources !~ m'\/Pattern'os)

6424

{ $resources = "/Pattern << $str >> " . $resources;

6425

}

6426

else

6427

{ $resources =~ s"/Pattern$ws*<<"'/Pattern<<' . $str"oges;

6428

}

6429

}

6430

6431

if (scalar %sidShading)

6432

{ my $str = '';

6433

for (sort keys %sidShading)

6434

{ $str .= "/$_ $sidShading{$_} 0 R";

6435

}

6436

if ($resources !~ m'\/Shading'os)

6437

{ $resources = "/Shading << $str >> " . $resources;

6438

}

6439

else

6440

{ $resources =~ s"/Shading$ws*<<"'/Shading<<' . $str"oges;

6441

}

6442

}

6443

6444

if (scalar %sidColorSpace)

6445

{ my $str = '';

6446

for (sort keys %sidColorSpace)

6447

{ $str .= "/$_ $sidColorSpace{$_} 0 R";

6448

}

6449

if ($resources !~ m'\/ColorSpace'os)

6450

{ $resources = "/ColorSpace << $str >> " . $resources;

6451

}

6452

else

6453

{ $resources =~ s"/ColorSpace$ws*<<"'/ColorSpace<<'.$str"oges;

6454

}

6455

}

6456

6457

if (exists $resurser{$resources})

6458

{ $resources = "$resurser{$resources} 0 R\n"; # Fanns ett identiskt,

6459

} # anv�nd det

6460

else

6461

{ $objNr++;

6462

if ( keys(%resurser) < 10)

6463

{ $resurser{$resources} = $objNr; # Spara 10 f�rsta resursobjekten

6464

}

6465

$objekt[$objNr] = $pos;

6466

$resursObjekt = "$objNr 0 obj<<$resources>>endobj\n";

6467

$pos += syswrite UTFIL, $resursObjekt ;

6468

$resources = "$objNr 0 R\n";

6469

}

6470

6471

%sidXObject = ();

6472

%sidExtGState = ();

6473

%sidFont = ();

6474

%sidPattern = ();

6475

%sidShading = ();

6476

%sidColorSpace = ();

6477

undef $checkCs;

6478

6479

$stream = '';

6480

}

6481

6482

if (! $parents[0])

6483

{ $objNr++;

6484

$parents[0] = $objNr;

6485

}

6486

my $parent = $parents[0];

6487

6488

if (($sidObjNr) && (! defined $objekt[$sidObjNr]))

6489

{ $ny = $sidObjNr;

6490

}

6491

else

6492

{ $objNr++;

6493

$ny = $objNr;

6494

}

6495

6496

$old{$oNr} = $ny;

6497

6498

if ($obj =~ m|/Parent$ws+(\d+)$ws+\d+$ws+R\b|os)

6499

{ $old{$1} = $parent;

6500

}

6501

6502

if ($obj =~ m/^\d+$ws+\d+$ws+obj$ws*<<(.+)>>$ws*endobj/os)

6503

{ $del1 = $1;

6504

}

6505

6506

if (%links)

6507

{ my $tSida = $sida + 1;

6508

if ((%links && $links{'-1'} && @{$links{'-1'}}) || (%links && $links{$tSida} && @{$links{$tSida}}))

6509

{ if ($del1 =~ m|/Annots$ws*([^\/\<\>]+)|os)

6510

{ $Annots = $1;

6511

@annots = ();

6512

if ($Annots =~ m'\[([^\[\]]*)\]'os)

6513

{ ; }

6514

else

6515

{ if ($Annots =~ m/\b(\d+)$ws+\d+$ws+R\b/os)

6516

{ $Annots = getObject($1);

6517

}

6518

}

6519

while ($Annots =~ m/\b(\d+)$ws+\d+$ws+R\b/ogs)

6520

{ push @annots, xform();

6521

}

6522

$del1 =~ s?/Annots$ws*([^\/\<\>]+)??os;

6523

}

6524

$Annots = '/Annots ' . mergeLinks() . ' 0 R';

6525

}

6526

}

6527

6528

if (! $taInterAkt)

6529

{ $del1 =~ s?$ws*/AA$ws*<<[^>]*>>??os;

6530

}

6531

6532

$del1 =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

6533

6534

if ($del1 !~ m'/Resources'o)

6535

{ $del1 .= "/Resources $resources";

6536

}

6537

6538

if (defined $streamObjekt) # En ny str�m ska l�ggas till

6539

{ if ($del1 =~ m|/Contents$ws+(\d+)$ws+\d+$ws+R|os)

6540

{ my $oldCont = $1;

6541

$del1 =~ s|/Contents$ws+(\d+)$ws+\d+$ws+R|'/Contents [' . "$oldCont 0 R $streamObjekt" . ']'|oes;

6542

}

6543

elsif ($del1 =~ m|/Contents$ws*\[|os)

6544

{ $del1 =~ s|/Contents$ws*\[([^\]]+)|'/Contents [' . $1 ." $streamObjekt"|oes;

6545

}

6546

else

6547

{ $del1 .= "/Contents $streamObjekt\n";

6548

}

6549

}

6550

6551

if ($Annots)

6552

{ $del1 .= $Annots;

6553

}

6554

6555

$utrad = "$ny 0 obj<<$del1>>";

6556

if (defined $del2)

6557

{ $utrad .= "stream\n$del2";

6558

}

6559

else

6560

{ $utrad .= "endobj\n";

6561

}

6562

6563

$objekt[$ny] = $pos;

6564

$pos += syswrite UTFIL, $utrad;

6565

6566

push @{$kids[0]}, $ny;

6567

$counts[0]++;

6568

if ($counts[0] > 9)

6569

{ ordnaNoder(8);

6570

}

6571

}

6572

6573

6574

sub checkResources

6575

{ my $pObj = shift;

6576

my $reStr = shift;

6577

my $to;

6578

6579

my $p = index($pObj, '/Resources');

6580

if ( $p < 0)

6581

{ ;

6582

}

6583

elsif ($pObj =~ m|/Resources($ws+\d+$ws+\d+$ws+R)|os)

6584

{ $reStr = $1;

6585

$to = $p + 10 + length($reStr);

6586

}

6587

else

6588

{ my $t = length($pObj);

6589

my $i = $p + 10;

6590

my $j = $i;

6591

my $k = 0;

6592

my $c;

6593

while ($i < $t)

6594

{ $c = substr($pObj,$i,1);

6595

if (($c eq '<' )

6596

|| ($c eq '>'))

6597

{ if ($c eq '<' )

6598

{ $k++;

6599

}

6600

else

6601

{ $k--;

6602

}

6603

last if ($k == 0);

6604

}

6605

$i++;

6606

}

6607

if ($i != $t)

6608

{ $i++;

6609

$reStr = substr($pObj, $j, ($i - $j));

6610

$to = $i;

6611

}

6612

}

6613

6614

if (wantarray)

6615

{ return ($reStr, $p, $to);

6616

}

6617

else

6618

{ return $reStr;

6619

}

6620

}

6621

6622

6623

sub translate

6624

{ if (exists $old{$1})

6625

{ $old{$1}; }

6626

else

6627

{ $old{$1} = ++$objNr;

6628

}

6629

}

6630

6631

sub behandlaNames

6632

{ my ($namnObj, $iForm) = @_;

6633

6634

my ($low, $high, $antNod0, $entry, $nyttNr, $ny, $obj,

6635

$fObjnr, $offSet, $bytes, $res, $key, $func, $corr, @objData);

6636

my (@nod0, @nodUpp, @kid, @soek, %nytt);

6637

6638

my $objektet = '';

6639

my $vektor = '';

6640

my $antal = 0;

6641

my $antNodUpp = 0;

6642

if ($namnObj)

6643

{ if ($iForm) # L�sning via interntabell

6644

{ $objektet = getObject($namnObj, 1);

6645

6646

if ($objektet =~ m'<<(.+)>>'ogs)

6647

{ $objektet = $1; }

6648

if ($objektet =~ s|/JavaScript$ws+(\d+)$ws+\d+$ws+R||os)

6649

{ my $byt = $1;

6650

push @kid, $1;

6651

while (scalar @kid)

6652

{ @soek = @kid;

6653

@kid = ();

6654

for my $sObj (@soek)

6655

{ $obj = getObject($sObj, 1);

6656

if ($obj =~ m|/Kids$ws*\[([^]]+)|ogs)

6657

{ $vektor = $1;

6658

}

6659

while ($vektor =~ m/\b(\d+)$ws+\d+$ws+R\b/ogs)

6660

{ push @kid, $1;

6661

}

6662

$vektor = '';

6663

if ($obj =~ m|/Names$ws*\[([^]]+)|ogs)

6664

{ $vektor = $1;

6665

}

6666

while ($vektor=~m|$([^$]+)\)$ws*(\d+)$ws+\d$ws+R|gos)

6667

{ $script{$1} = $2;

6668

}

6669

}

6670

}

6671

}

6672

}

6673

else # L�sning av ett "doc"

6674

{ $objektet = getObject($namnObj);

6675

if ($objektet =~ m'<<(.+)>>'ogs)

6676

{ $objektet = $1; }

6677

if ($objektet =~ s|/JavaScript$ws+(\d+)$ws+\d+$ws+R||os)

6678

{ my $byt = $1;

6679

push @kid, $1;

6680

while (scalar @kid)

6681

{ @soek = @kid;

6682

@kid = ();

6683

for my $sObj (@soek)

6684

{ $obj = getObject($sObj);

6685

if ($obj =~ m|/Kids$ws*\[([^]]+)|ogs)

6686

{ $vektor = $1;

6687

}

6688

while ($vektor =~ m|\b(\d+)$ws+\d+$ws+R\b|ogs)

6689

{ push @kid, $1;

6690

}

6691

undef $vektor;

6692

if ($obj =~ m|/Names$ws*\[([^]]+)|ogs)

6693

{ $vektor = $1;

6694

}

6695

while($vektor =~ m/$([^$]+)\)$ws*(\d+)$ws+\d\$ws+R/gos)

6696

{ $script{$1} = $2;

6697

}

6698

}

6699

}

6700

}

6701

}

6702

}

6703

for my $filnamn (@jsfiler)

6704

{ inkludera($filnamn);

6705

}

6706

my @nya = (keys %nyaFunk);

6707

while (scalar @nya)

6708

{ my @behandla = @nya;

6709

@nya = ();

6710

for $key (@behandla)

6711

{ if (exists $initScript{$key})

6712

{ if (exists $nyaFunk{$key})

6713

{ $initScript{$key} = $nyaFunk{$key};

6714

}

6715

if (exists $script{$key}) # f�retr�de f�r nya funktioner !

6716

{ delete $script{$key}; # gammalt script m samma namn plockas bort

6717

}

6718

my @fall = ($initScript{$key} =~ m'([\w\d\_\$]+)\s*\('ogs);

6719

for (@fall)

6720

{ if (($_ ne $key) && (exists $nyaFunk{$_}))

6721

{ $initScript{$_} = $nyaFunk{$_};

6722

push @nya, $_;

6723

}

6724

}

6725

}

6726

}

6727

}

6728

while (($key, $func) = each %nyaFunk)

6729

{ $fObjnr = skrivJS($func);

6730

$script{$key} = $fObjnr;

6731

$nytt{$key} = $fObjnr;

6732

}

6733

6734

if (scalar %fields)

6735

{ push @inits, 'Ladda();';

6736

$fObjnr = defLadda();

6737

if ($duplicateInits)

6738

{ $script{'Ladda'} = $fObjnr;

6739

$nytt{'Ladda'} = $fObjnr;

6740

}

6741

}

6742

6743

if ((scalar @inits) && ($duplicateInits))

6744

{ $fObjnr = defInit();

6745

$script{'Init'} = $fObjnr;

6746

$nytt{'Init'} = $fObjnr;

6747

}

6748

undef @jsfiler;

6749

6750

for my $key (sort (keys %script))

6751

{ if (! defined $low)

6752

{ $objNr++;

6753

$ny = $objNr;

6754

$objekt[$ny] = $pos;

6755

$obj = "$ny 0 obj\n";

6756

$low = $key;

6757

$obj .= '<< /Names [';

6758

}

6759

$high = $key;

6760

$obj .= '(' . "$key" . ')';

6761

if (! exists $nytt{$key})

6762

{ $nyttNr = quickxform($script{$key});

6763

}

6764

else

6765

{ $nyttNr = $script{$key};

6766

}

6767

$obj .= "$nyttNr 0 R\n";

6768

$antal++;

6769

if ($antal > 9)

6770

{ $obj .= ' ]/Limits [(' . "$low" . ')(' . "$high" . ')] >>' . "endobj\n";

6771

$pos += syswrite UTFIL, $obj;

6772

push @nod0, \[$ny, $low, $high];

6773

$antNod0++;

6774

undef $low;

6775

$antal = 0;

6776

}

6777

}

6778

if ($antal)

6779

{ $obj .= ']/Limits [(' . $low . ')(' . $high . ')]>>' . "endobj\n";

6780

$pos += syswrite UTFIL, $obj;

6781

push @nod0, \[$ny, $low, $high];

6782

$antNod0++;

6783

}

6784

$antal = 0;

6785

6786

while (scalar @nod0)

6787

{ for $entry (@nod0)

6788

{ if ($antal == 0)

6789

{ $objNr++;

6790

$objekt[$objNr] = $pos;

6791

$obj = "$objNr 0 obj\n";

6792

$low = $$entry->[1];

6793

$obj .= '<

6794

}

6795

$high = $$entry->[2];

6796

$obj .= " $$entry->[0] 0 R";

6797

$antal++;

6798

if ($antal > 9)

6799

{ $obj .= ']/Limits [(' . $low . ')(' . $high . ')]>>' . "endobj\n";

6800

$pos += syswrite UTFIL, $obj;

6801

push @nodUpp, \[$objNr, $low, $high];

6802

$antNodUpp++;

6803

undef $low;

6804

$antal = 0;

6805

}

6806

}

6807

if ($antal > 0)

6808

{ if ($antNodUpp == 0) # inget i noderna �ver

6809

{ $obj .= ']>>' . "endobj\n";

6810

$pos += syswrite UTFIL, $obj;

6811

}

6812

else

6813

{ $obj .= ']/Limits [(' . "$low" . ')(' . "$high" . ')]>>' . "endobj\n";

6814

$pos += syswrite UTFIL, $obj;

6815

push @nodUpp, \[$objNr, $low, $high];

6816

$antNodUpp++;

6817

undef $low;

6818

$antal = 0;

6819

}

6820

}

6821

@nod0 = @nodUpp;

6822

$antNod0 = $antNodUpp;

6823

undef @nodUpp;

6824

$antNodUpp = 0;

6825

}

6826

6827

6828

$ny = $objNr;

6829

$objektet =~ s|$ws*/JavaScript$ws*\d+$ws+\d+$ws+R||os;

6830

$objektet =~ s/\b(\d+)$ws+\d+$ws+R\b/xform() . ' 0 R'/oegs;

6831

if (scalar %script)

6832

{ $objektet .= "\n/JavaScript $ny 0 R\n";

6833

}

6834

$objNr++;

6835

$ny = $objNr;

6836

$objekt[$ny] = $pos;

6837

$objektet = "$ny 0 obj<<" . $objektet . ">>endobj\n";

6838

$pos += syswrite UTFIL, $objektet;

6839

return $ny;

6840

}

6841

6842

6843

sub quickxform

6844

{ my $inNr = shift;

6845

if (exists $old{$inNr})

6846

{ $old{$inNr}; }

6847

else

6848

{ push @skapa, [$inNr, ++$objNr];

6849

$old{$inNr} = $objNr;

6850

}

6851

}

6852

6853

6854

sub skrivKedja

6855

{ my $code = ' ';

6856

6857

for (values %initScript)

6858

{ $code .= $_ . "\n";

6859

}

6860

$code .= "function Init() { ";

6861

$code .= 'if (typeof this.info.ModDate == "object")' . " { return true; }";

6862

for (@inits)

6863

{ $code .= $_ . "\n";

6864

}

6865

$code .= "} Init(); ";

6866

6867

my $spar = skrivJS($code);

6868

undef @inits;

6869

undef %initScript;

6870

return $spar;

6871

}

6872

6873

6874

6875

sub skrivJS

6876

{ my $kod = shift;

6877

my $obj;

6878

if (($compress) && (length($kod) > 99))

6879

{ $objNr++;

6880

$objekt[$objNr] = $pos;

6881

my $spar = $objNr;

6882

$kod = compress($kod);

6883

my $langd = length($kod);

6884

$obj = "$objNr 0 obj<

6885

. "/Length $langd>>stream\n" . $kod

6886

. "\nendstream\nendobj\n";

6887

$pos += syswrite UTFIL, $obj;

6888

$objNr++;

6889

$objekt[$objNr] = $pos;

6890

$obj = "$objNr 0 obj<>endobj\n";

6891

}

6892

else

6893

{ $kod =~ s'\('\\('gso;

6894

$kod =~ s'\)'\\)'gso;

6895

$objNr++;

6896

$objekt[$objNr] = $pos;

6897

$obj = "$objNr 0 obj<

6898

$obj .= ">>endobj\n";

6899

}

6900

$pos += syswrite UTFIL, $obj;

6901

return $objNr;

6902

}

6903

6904

sub inkludera

6905

{ my $jsfil = shift;

6906

my $fil;

6907

if ($jsfil !~ m'\{'os)

6908

{ open (JSFIL, "<$jsfil") || return;

6909

while ()

6910

{ $fil .= $_;}

6911

6912

close JSFIL;

6913

}

6914

else

6915

{ $fil = $jsfil;

6916

}

6917

$fil =~ s|function\s+([\w\_\d\$]+)\s*\(|"zXyZcUt function $1 ("|sge;

6918

my @funcs = split/zXyZcUt /, $fil;

6919

for my $kod (@funcs)

6920

{ if ($kod =~ m'^function ([\w\_\d\$]+)'os)

6921

{ $nyaFunk{$1} = $kod;

6922

}

6923

}

6924

}

6925

6926

6927

sub defLadda

6928

{ my $code = "function Ladda() {";

6929

for (keys %fields)

6930

{ my $val = $fields{$_};

6931

if ($val =~ m'\s*js\s*\:(.+)'oi)

6932

{ $val = $1;

6933

$code .= "if (this.getField('$_')) this.getField('$_').value = $val; ";

6934

}

6935

else

6936

{ $val =~ s/([^A-Za-z0-9\-_.!* ])/sprintf("%%%02X", ord($1))/ge;

6937

$code .= "if (this.getField('$_')) this.getField('$_').value = unescape('$val'); ";

6938

}

6939

6940

}

6941

$code .= " 1;} ";

6942

6943

6944

$initScript{'Ladda'} = $code;

6945

if ($duplicateInits)

6946

{ my $ny = skrivJS($code);

6947

return $ny;

6948

}

6949

else

6950

{ return 1;

6951

}

6952

}

6953

6954

sub defInit

6955

{ my $code = "function Init() { ";

6956

$code .= 'if (typeof this.info.ModDate == "object")' . " { return true; } ";

6957

for (@inits)

6958

{ $code .= $_ . "\n";

6959

}

6960

$code .= '}';

6961

6962

my $ny = skrivJS($code);

6963

return $ny;

6964

6965

}

6966

6967

6968

6969

sub errLog

6970

{ no strict 'refs';

2075

6971

my $mess = shift;

6972

my $endMess = " $mess \n More information might be found in";

6973

if ($runfil)

6974

{ $log .= "Log~Err: $mess\n";

6975

$endMess .= "\n $runfil";

6976

if (! $pos)

6977

{ $log .= "Log~Err: No pdf-file has been initiated\n";

6978

}

6979

elsif ($pos > 15000000)

6980

{ $log .= "Log~Err: Current pdf-file is very big: $pos bytes, will not try to finish it\n";

6981

}

6982

else

6983

{ $log .= "Log~Err: Will try to finish current pdf-file\n";

6984

$endMess .= "\n $utfil";

6985

}

6986

}

6987

my $errLog = 'error.log';

6988

my $now = localtime();

6989

my $lpos = $pos || 'undef';

6990

my $lobjNr = $objNr || 'undef';

6991

my $lutfil = $utfil || 'undef';

6992

6993

my $lrunfil = $runfil || 'undef';

6994

open (ERRLOG, ">$errLog") || croak "$mess can't open an error log, $!";

6995

print ERRLOG "\n$mess\n\n";

6996

print ERRLOG Carp::longmess("The error occurred when executing:\n");

6997

print ERRLOG "\nSituation when the error occurred\n\n";

6998

print ERRLOG " Bytes written to the current pdf-file, pos = $lpos\n";

6999

print ERRLOG " Object processed, not necessarily written objNr = $lobjNr\n";

7000

print ERRLOG " Current pdf-file, utfil = $lutfil\n";

7001

print ERRLOG " File logging the run, runfil = $lrunfil\n";

7002

print ERRLOG " Local time = $now\n";

7003

print ERRLOG "\n\n";

7004

close ERRLOG;

7005

$endMess .= "\n $errLog";

7006

if (($pos) && ($pos < 15000000))

7007

{ prEnd();

7008

}

7009

print STDERR Carp::shortmess("An error occurred \n");

7010

croak "$endMess\n";

7011

}