Codebase list liblog-report-perl / f83fc87
distribution Log-Report-0.02.tar.gz Mark Overmeer authored 16 years ago Mark Overmeer committed 6 years ago
90 changed file(s) with 7992 addition(s) and 0 deletion(s). Raw diff Collapse all Expand all
+24
-0
ChangeLog less more
0
1 ==== version history of Log::Report
2
3 version 0.02: Mon May 28 00:49:52 CEST 2007
4 - added HTML documentation to http://perl.overmeer.net/log-report/
5 - added README and Changelog to MANIFEST
6 - filters are not defined on the dispatcher object, but under
7 control of Log::Report::report().
8 - Log::Report::Message new methods append(), msgid(), and prepend()
9 - added Log::Report::Exception and Log::Report::Dispatcher::Try
10 - added isValidReason() and isFatal() to Log::Report
11 - added Log::Report::Message::untranslated();
12 - Log::Report::report() will convert untranslated strings into
13 Log::Report::Message objects internally too.
14
15 - by David Cantrell via cpan-testers:
16 . require at least perl 5.8.2, for POSIX :local_h and because
17 unique was broken before that release.
18 . t/00use.t cannot test LogDispatch and Gettext, because they
19 depend on optional module
20 . t/50file.t failed because no -t STDERR
21
22 version 0.01: Fri May 25 12:13:13 CEST 2007
23 - initial
+40
-0
MANIFEST less more
0 ChangeLog
1 MANIFEST
2 Makefile.PL
3 README
4 lib/Log/Report.pm
5 lib/Log/Report/Dispatcher.pm
6 lib/Log/Report/Dispatcher/File.pm
7 lib/Log/Report/Dispatcher/Log4perl.pm
8 lib/Log/Report/Dispatcher/LogDispatch.pm
9 lib/Log/Report/Dispatcher/Syslog.pm
10 lib/Log/Report/Dispatcher/Try.pm
11 lib/Log/Report/Exception.pm
12 lib/Log/Report/Extract/PerlPPI.pm
13 lib/Log/Report/Lexicon/Index.pm
14 lib/Log/Report/Lexicon/PO.pm
15 lib/Log/Report/Lexicon/POT.pm
16 lib/Log/Report/Lexicon/POTcompact.pm
17 lib/Log/Report/Message.pm
18 lib/Log/Report/Translator.pm
19 lib/Log/Report/Translator/Gettext.pm
20 lib/Log/Report/Translator/POT.pm
21 lib/Log/Report/Util.pm
22 lib/Log/Report/messages/log-report.utf-8.po
23 lib/Log/Report/messages/log-report/nl_NL.po
24 t/00use.t
25 t/05util.t
26 t/10interp.t
27 t/11concat.t
28 t/20pot_read.t
29 t/21pot_modif.t
30 t/22compact.t
31 t/30index.t
32 t/31stack.t
33 t/40ppi.t
34 t/50file.t
35 t/51syslog.t
36 t/52logdisp.t
37 t/53log4perl.t
38 t/54try.t
39 t/hello-world-slovak.po
+34
-0
Makefile.PL less more
0 use ExtUtils::MakeMaker;
1
2 use 5.8.2;
3
4 WriteMakefile
5 ( NAME => 'Log::Report'
6 , VERSION => '0.02'
7 , PREREQ_PM => { Test::More => 0.47 }
8 , AUTHOR => 'Mark Overmeer'
9 , ABSTRACT => 'report a problem, pluggable handlers and language support'
10 );
11
12 sub MY::postamble { <<'__POSTAMBLE' }
13
14 # for OODoc's oodist, DIST
15 RAWDIR = ../public_html/log-report/raw
16 DISTDIR = ../public_html/log-report/source
17 LICENSE = artistic
18
19 # for OODoc's oodist, POD
20 FIRST_YEAR = 2007
21 EMAIL = perl@overmeer.net
22 WEBSITE = http://perl.overmeer.net/log-report/
23
24 # for OODoc's oodist, HTML
25 HTML_OUTPUT = ../public_html/log-report/html
26 HTML_DOCROOT = /log-report/html
27 HTML_PACKAGE = ../public_html/log-report/htmlpkg
28
29 # for Log::Report
30 xgettext: $(TO_INST_PM)
31 PERL5LIB=lib bin/xgettext-perl --mode=DEBUG \
32 -p lib/Log/Report/messages
33 __POSTAMBLE
+14
-0
README less more
0 ==== README for Log::Report
1 = Last update: 25 May 2007, Mark Overmeer
2
3 The Log::Report module is entangled with various other modules, which
4 may each take a long time to install but then are never used. Therefore,
5 these modules will produce compile-time errors.
6
7 Optional modules: Needed for:
8 Log::Dispatch and ::* Log::Report::Dispatcher::LogDispatch
9 Log::Log4perl Log::Report::Dispatcher::Log4perl
10 Sys::Syslog Log::Report::Dispatcher::Syslog
11 PPI Log::Report::Extract::PerlPPI
12 Locale::gettext Log::Report::Translator::Gettext
13
+23
-0
html/manual/doclist.html less more
0
1 <html>
2 <head>
3 <title><!--{title}--></title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <b>Show</b>
9 <ul>
10 <li>class <a href="relations.html">relations</a></li>
11 <li>methods <a href="grouped.html">grouped</a></li>
12 <li>methods <a href="sorted.html">alphabeticly</a></li>
13 <li><b>documentation overview</b></li>
14 </ul>
15 <!--{list SYNOPSIS }-->
16 <!--{list DESCRIPTION }-->
17 <!--{list OVERLOADED show_subroutines => COUNT }-->
18 <!--{list METHODS show_subroutines => COUNT }-->
19 <!--{list DETAILS }-->
20
21 </body>
22 </html>
+20
-0
html/manual/grouped.html less more
0
1 <html>
2 <head>
3 <title><!--{title}--></title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <b>Show</b>
9 <ul>
10 <li>class <a href="relations.html">relations</a></li>
11 <li><b>methods grouped</b></li>
12 <li>methods <a href="sorted.html">alphabeticly</a></li>
13 <li>documentation <a href="doclist.html">overview</a></li>
14 </ul>
15 <!--{list OVERLOADED show_sections => NAME}-->
16 <!--{list METHODS show_sections => NAME}-->
17
18 </body>
19 </html>
+25
-0
html/manual/head.html less more
0
1 <html>
2 <head>
3 <title><!--{title}--></title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <table width="100%">
9 <tr><td valign="top">
10 <b>MailBox</b> <!--{a front}-->documentation</a><br />
11 <!--{distribution}--> <!--{version}--><br />
12 produced <!--{date}-->
13 </td><td align="center" valign="bottom">
14 <h1><!--{manual}--><br /><font size="5"><!--{name}--></font></h1>
15 </td><td valign="top">
16 <!--{a manuals}-->all manuals</a><br />
17 <!--{a methods}-->all methods</a><br />
18 <!--{a diagnostics}-->all diagnostics</a><br />
19 <!--{a details}-->all details</a><br />
20 </td></tr>
21 </table>
22
23 </body>
24 </html>
+22
-0
html/manual/index.html less more
0
1 <html>
2 <head>
3 <title><!--{title}--></title>
4 <!--{meta}-->
5 </head>
6
7 <frameset rows="130,*" frameborder="NO">
8 <frame src="head.html" name="head">
9 <frameset cols="*,350" frameborder="NO">
10 <frame src="main.html" name="main">
11 <frame src="relations.html" name="grouped">
12 </frameset>
13 <frameset>
14
15 <noframes>
16 <body>
17 Sorry, you need frames for this documentation.
18 </body>
19 </noframes>
20
21 </html>
+14
-0
html/manual/main.html less more
0
1 <html>
2 <head>
3 <title><!--{title}--></title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <!--{chapter SYNOPSIS }-->
9 <!--{chapter DESCRIPTION}-->
10 <!--{chapter DETAILS }-->
11
12 </body>
13 </html>
+20
-0
html/manual/methods.html less more
0
1 <html>
2 <head>
3 <title><!--{title}--></title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <!--{chapter OVERLOADED show_examples => EXPAND,
9 show_diagnostics => EXPAND,
10 show_sub_descriptions => ALL
11 }-->
12
13 <!--{chapter METHODS show_examples => EXPAND,
14 show_diagnostics => EXPAND,
15 show_sub_descriptions => ALL
16 }-->
17
18 </body>
19 </html>
+20
-0
html/manual/relations.html less more
0
1 <html>
2 <head>
3 <title><!--{title}--></title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <b>Show</b>
9 <ul>
10 <li><b>class relations</b></li>
11 <li>methods <a href="grouped.html">grouped</a></li>
12 <li>methods <a href="sorted.html">alphabeticly</a></li>
13 <li>documentation <a href="doclist.html">overview</a></li>
14 </ul>
15
16 <!--{inheritance}-->
17
18 </body>
19 </html>
+24
-0
html/manual/sorted.html less more
0 <html>
1 <head>
2 <title><!--{title}--></title>
3 <!--{meta}-->
4 </head>
5 <body>
6
7 <b>Show</b>
8 <ul>
9 <li>class <a href="relations.html">relations</a></li>
10 <li>methods <a href="grouped.html">grouped</a></li>
11 <li><b>methods alphabeticly</b></li>
12 <li>documentation <a href="doclist.html">overview</a></li>
13 </ul>
14 <!--{list METHODS show_subroutines => COUNT}-->
15
16 Overloaded:
17 <!--{list ALL subroutine_types => overload}--><br />
18
19 Methods:
20 <!--{list ALL subroutine_types => method|tie}--><br />
21
22 </body>
23 </html>
+44
-0
html/other/README.install less more
0
1 Mail::Box documentation on HTML
2 ===============================
3
4 An installed version of the manual pages of Mail::Box in HTML can be found
5 at http://perl.overmeer.net/mailbox/html/
6
7 All installation rules may change in future releases. Please read this
8 installation file carefully, each time.
9
10 == Requirements
11
12 - To install this documentation set, you must to be able to run CGI
13 scripts on your web-server.
14 - About 6MB disk-space
15 - absolute location /mailbox/html to the top of your domain
16
17 == Installation
18
19 1) Unpack all files in $web/mailbox/html/
20
21 2) Be sure that mailbox/html/jump.cgi has execute rights
22
23 3) Be sure that web-server's configuration permit jump.cgi to run:
24
25 Options +ExecCGI
26 AddHandler cgi-script .cgi
27
28 == Other location
29
30 If you need to install the documentation on a different location than
31 you need to change some absolute paths in the html files. On Unix/Linux,
32 you can simply do:
33
34 for f in $(find . -type f);
35 do
36 sed <$f >x 's!/mailbox/html!/new/location!g' && mv x $f
37 done
38
39 == Cannot run CGI
40
41 Now you have a problem. You *CAN NOT* point the cgi link to the public
42 CGI script, because used numbers will change for each (pre-)release. So
43 you have to use the public installation of these pages.
+29
-0
html/other/details/index.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; All Details</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <table width="100%">
9 <tr><td valign="top">
10 <b>MailBox</b> <!--{a front}-->documentation</a><br />
11 <!--{distribution}--> <!--{version}--><br />
12 produced <!--{date}-->
13 </td><td align="center" valign="bottom">
14 <h1><font size="4"><!--{project}--></font><br /> All details</h1>
15 </td><td valign="top">
16 <!--{a manuals}-->all manuals</a><br />
17 <!--{a methods}-->all methods</a><br />
18 <!--{a diagnostics}-->all diagnostics</a><br />
19 <b>all details</b><br />
20 </td></tr>
21 </table>
22
23 <table cellspacing="10">
24 <!--{index DETAILS table_columns => 3}-->
25 </table>
26
27 </body>
28 </html>
+14
-0
html/other/diagnostics/errors.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Errors</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <table>
9 <!--{index DIAGNOSTICS type => error}-->
10 </table>
11
12 </body>
13 </html>
+35
-0
html/other/diagnostics/head.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; All Diagnostics</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <table width="100%">
9 <tr><td valign="top">
10 <b>MailBox</b> <!--{a front}-->Documentation</a><br />
11 <!--{distribution}--> <!--{version}--><br />
12 produced <!--{date}-->
13 </td><td align="center" valign="bottom">
14 <h1><font size="4"><!--{project}--></font><br /> All Diagnostics</h1>
15 </td><td valign="top">
16 <!--{a manuals}-->all manuals</a><br />
17 <!--{a methods}-->all methods</a><br />
18 <b>all diagnostics</b><br />
19 <!--{a details}-->all details</a><br />
20 </td></tr>
21
22 <tr><td>&nbsp;</td>
23 <td align="center">
24 <font color="red">These pages are very incomplete on the moment</font><br />
25 <a href="errors.html" target="diag">Errors</a>&nbsp;&nbsp;--
26 <a href="warnings.html" target="diag">Warnings</a>&nbsp;&nbsp;--
27 <a href="notices.html" target="diag">Notices</a></td>
28 <td>&nbsp;</td>
29 </tr>
30
31 </table>
32
33 </body>
34 </html>
+19
-0
html/other/diagnostics/index.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; All Diagnostics</title>
4 <!--{meta}-->
5 </head>
6
7 <frameset rows="150,*" frameborder="NO">
8 <frame src="head.html" name="head">
9 <frame src="errors.html" name="diag">
10 <frameset>
11
12 <noframes>
13 <body>
14 Sorry, you need frames for this documentation.
15 </body>
16 </noframes>
17
18 </html>
+14
-0
html/other/diagnostics/notices.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Notices</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <table>
9 <!--{index DIAGNOSTICS type => notice}-->
10 </table>
11
12 </body>
13 </html>
+14
-0
html/other/diagnostics/warnings.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Warnings</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <table>
9 <!--{index DIAGNOSTICS type => warning}-->
10 </table>
11
12 </body>
13 </html>
+40
-0
html/other/index.html less more
0
1 <html>
2 <head>
3 <title><!--{project}--> <!--{version}--></title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <center>
9 <table width="80%">
10 <tr><td>
11 <h1><!--{project}--></h1>
12
13 <dl>
14 <dt><b><!--{a manuals}-->All packages&nbsp;&gt;&gt;</a></b></dt>
15 <dd><p>Lists all packages which are currently included in this
16 documentation system by name.</p></dd>
17
18 <dt><b><!--{a methods}-->All methods&nbsp;&gt;&gt;</a></b><dt>
19 <dd><p>The methods which are described, sorted alphabetically. Sometimes
20 you have a feeling about the name of a method, but no idea where to
21 find it.</p></dd>
22
23 <dt><b><!--{a diagnostics}-->All diagnostics&nbsp;&gt;&gt;</a></b></dt>
24 <dd><p>Explanation of the meaning of error and warning messages, produced
25 by the library. You can also find-out which method produces the
26 complaint, which may help resolving it.<br />
27 This page is far from complete, on the moment.</p>
28
29 <dt><b><!--{a details}-->All details&nbsp;&gt;&gt;</a></b></dt>
30 <dd><p>Many manual pages contain detailed explanations on how to use
31 the objects, with background information, examples, FAQ, etc.
32 This page provides an overview on all these manual page sections.<br />
33 </dl>
34
35 </table>
36 </center>
37
38 </body>
39 </html>
+69
-0
html/other/jump.cgi less more
0 #!/usr/bin/perl -T
1
2 use strict;
3 use warnings;
4
5 print "Content-Type: text/html\r\n\r\n";
6
7 # Get the question
8
9 my $to = $ENV{QUERY_STRING} || '';
10 my ($manual, $unique) = $to =~ m/([\w:%]+)\&(\d+)/;
11 $manual =~ s/\%[a-fA-F0-9]{2}/chr hex $1/ge;
12
13 # Contact the database
14
15 my $DB = $0;
16 $DB =~ s/[\w\.]+$/markers/;
17
18 open DB, '<', $DB or die "Cannot read markers from $DB: $!\n";
19 my $root = <DB>;
20 chomp $root;
21
22 # Lookup location of item in the manual page
23
24 my ($nr, $in, $page);
25 while( <DB> )
26 { ($nr, $in, $page) = split " ", $_, 3;
27 last if $nr eq $unique && $in eq $manual;
28 }
29
30 die "Cannot find id $to for $manual in $DB.\n"
31 unless $nr eq $unique;
32
33 chomp $page;
34
35 # Keep same index on the right, if possible
36
37 my $show = "relations.html";
38 if(my $refer = $ENV{HTTP_REFERER})
39 { $show = "$1.html"
40 if $refer =~ m/(doclist|sorted|grouped|relations)\.html/;
41 }
42
43 # Produce page, which is compible to the normal html/manual/index.html
44 # This cgi script is processed by the template system too.
45
46 print <<PAGE;
47 <html>
48 <head>
49 <title>$manual</title>
50 <!--{meta}-->
51 </head>
52
53 <frameset rows="130,*" frameborder="NO">
54 <frame src="$root/$manual/head.html" name="head">
55 <frameset cols="*,350" frameborder="NO">
56 <frame src="$root/$manual/$page#$unique" name="main">
57 <frame src="$root/$manual/$show" name="grouped">
58 </frameset>
59 </frameset>
60
61 <noframes>
62 <body>
63 Sorry, you need frames for this documentation.
64 </body>
65 </noframes>
66
67 </html>
68 PAGE
+25
-0
html/other/manuals/head.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; All Manuals</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <table width="100%">
9 <tr><td valign="top">
10 <b>MailBox</b> <!--{a front}-->Documentation</a><br />
11 <!--{distribution}--> <!--{version}--><br />
12 produced <!--{date}-->
13 </td><td align="center" valign="bottom">
14 <h1><font size="4"><!--{project}--></font><br /> All Manuals</h1>
15 </td><td valign="top">
16 <b>all manuals</b><br />
17 <!--{a methods}-->all methods</a><br />
18 <!--{a diagnostics}-->all diagnostics</a><br />
19 <!--{a details}-->all details</a><br />
20 </td></tr>
21 </table>
22
23 </body>
24 </html>
+19
-0
html/other/manuals/index.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; All Manuals</title>
4 <!--{meta}-->
5 </head>
6
7 <frameset rows="150,*" frameborder="NO">
8 <frame src="head.html" name="head">
9 <frame src="list.html" name="list">
10 <frameset>
11
12 <noframes>
13 <body>
14 Sorry, you need frames for this documentation.
15 </body>
16 </noframes>
17
18 </html>
+20
-0
html/other/manuals/list.html less more
0 <html>
1 <head>
2 <title><!--{project}--> Manuals</title>
3 <!--{meta}-->
4 </head>
5 <body>
6
7 <center>
8 <table width="80%" cellspacing="10">
9 <!--{index MANUALS table_columns => 3}-->
10 </table>
11 </center>
12
13 <hr noshade="noshade" />
14 <a href="mailto:mark@overmeer.net">Mark Overmeer</a>.
15 Documentation of <!--{version}-->,
16 produced with OODoc on <!--{date}-->.
17
18 </body>
19 </html>
+16
-0
html/other/methods/A.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with A</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>A</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with A}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/B.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with B</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>B</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with B}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/C.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with C</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>C</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with C}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/D.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with D</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>D</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with D}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/E.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with E</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>E</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with E}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/F.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with F</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>F</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with F}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/G.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with G</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>G</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => G}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/H.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with H</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>H</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => H}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/I.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with I</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>I</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => I}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/J.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with J</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>J</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => J}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/K.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with K</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>K</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => K}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/L.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with L</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>L</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => L}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/M.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with M</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>M</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => M}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/N.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with N</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>N</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => N}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/O.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with O</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>O</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => O}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/P.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with P</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>P</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => P}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/Q.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with Q</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>Q</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => Q}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/R.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with R</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>R</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with => R}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/S.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with S</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>S</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with S}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/T.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with T</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>T</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with T}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/U.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with U</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>U</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with U}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/V.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with V</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>V</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with V}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/W.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with W</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>W</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with W}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/X.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with X</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>X</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with X}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/Y.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with Y</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>Y</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with Y}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/Z.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Methods with Z</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>Z</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with Z}-->
12 </table>
13
14 </body>
15 </html>
+16
-0
html/other/methods/_.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; Other methods</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <h1>Other methods</h1>
9
10 <table>
11 <!--{index SUBROUTINES starting_with _}-->
12 </table>
13
14 </body>
15 </html>
+55
-0
html/other/methods/head.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; All Methods</title>
4 <!--{meta}-->
5 </head>
6 <body>
7
8 <table width="100%">
9 <tr><td valign="top">
10 <b>Mailbox</b> <!--{a front}-->Documentation</a><br />
11 <!--{distribution}--> <!--{version}--><br />
12 produced <!--{date}-->
13 </td><td align="center" valign="bottom">
14 <h1><font size="4"><!--{project}--></font><br /> All Methods</h1>
15 </td><td valign="top">
16 <!--{a manuals}-->all manuals</a><br />
17 <b>all methods</b><br />
18 <!--{a diagnostics}-->all diagnostics</a><br />
19 <!--{a details}-->all details</a><br />
20 </td></tr>
21 </table>
22
23 <center>
24 <a href="A.html" target="char">A</A>&nbsp;&nbsp;
25 <a href="B.html" target="char">B</A>&nbsp;&nbsp;
26 <a href="C.html" target="char">C</A>&nbsp;&nbsp;
27 <a href="D.html" target="char">D</A>&nbsp;&nbsp;
28 <a href="E.html" target="char">E</A>&nbsp;&nbsp;
29 <a href="F.html" target="char">F</A>&nbsp;&nbsp;
30 <a href="G.html" target="char">G</A>&nbsp;&nbsp;
31 <a href="H.html" target="char">H</A>&nbsp;&nbsp;
32 <a href="I.html" target="char">I</A>&nbsp;&nbsp;
33 <a href="J.html" target="char">J</A>&nbsp;&nbsp;
34 <a href="K.html" target="char">K</A>&nbsp;&nbsp;
35 <a href="L.html" target="char">L</A>&nbsp;&nbsp;
36 <a href="M.html" target="char">M</A>&nbsp;&nbsp;
37 <a href="N.html" target="char">N</A>&nbsp;&nbsp;
38 <a href="O.html" target="char">O</A>&nbsp;&nbsp;
39 <a href="P.html" target="char">P</A>&nbsp;&nbsp;
40 <a href="Q.html" target="char">Q</A>&nbsp;&nbsp;
41 <a href="R.html" target="char">R</A>&nbsp;&nbsp;
42 <a href="S.html" target="char">S</A>&nbsp;&nbsp;
43 <a href="T.html" target="char">T</A>&nbsp;&nbsp;
44 <a href="U.html" target="char">U</A>&nbsp;&nbsp;
45 <a href="V.html" target="char">V</A>&nbsp;&nbsp;
46 <a href="W.html" target="char">W</A>&nbsp;&nbsp;
47 <a href="X.html" target="char">X</A>&nbsp;&nbsp;
48 <a href="Y.html" target="char">Y</A>&nbsp;&nbsp;
49 <a href="Z.html" target="char">Z</A>&nbsp;&nbsp;
50 <a href="_.html" target="char">Other</A>
51 </center>
52
53 </body>
54 </html>
+19
-0
html/other/methods/index.html less more
0
1 <html>
2 <head>
3 <title><!--{project}-->; All Methods</title>
4 <!--{meta}-->
5 </head>
6
7 <frameset rows="150,*" frameborder="NO">
8 <frame src="head.html" name="head">
9 <frame src="A.html" name="char">
10 <frameset>
11
12 <noframes>
13 <body>
14 Sorry, you need frames for this documentation.
15 </body>
16 </noframes>
17
18 </html>
+26
-0
html/other/oodoc.css less more
0
1 BODY {
2 font-family: Arial, Herlvetica, sans-serif
3 }
4
5 H2 {
6 font-variant: small-caps;
7 }
8
9 A:link {
10 color: green;
11 text-decoration: none;
12 }
13
14 A:visited {
15 color: blue;
16 text-decoration: none;
17 }
18
19 UL {
20 margin-top: 0;
21 }
22
23 DL {
24 margin-top: 1ex;
25 }
+123
-0
lib/Log/Report/Dispatcher/File.pm less more
0 use warnings;
1 use strict;
2
3 package Log::Report::Dispatcher::File;
4 use base 'Log::Report::Dispatcher';
5
6 use Log::Report 'log-report', syntax => 'SHORT';
7 use IO::File;
8
9 =chapter NAME
10 Log::Report::Dispatcher::File - send messages to a file or file-handle
11
12 =chapter SYNOPSIS
13 # automatically created when STDERR is open
14 dispatcher Log::Report::Dispatcher::File => 'stderr'
15 , to => \*STDERR, accept => 'NOTICE-';
16
17 # disable default dispatcher
18 dispatcher close => 'stderr';
19
20 # let dispatcher open and close the file
21 dispatcher FILE => 'mylog', to => '/var/log/mylog'
22 , charset => 'utf-8';
23 ...
24 dispatcher close => 'mylog'; # will close file
25
26 # open yourself, then also close yourself
27 open OUT, ">:encoding('iso-8859-1')", '/var/log/mylog'
28 or fault "...";
29 dispatcher FILE => 'mylog', to => \*OUT;
30 ...
31 dispatcher close => 'mylog';
32 close OUT;
33
34 # dispatch into a scalar
35 my $output = '';
36 open $outfile, '>', \$output;
37 dispatcher FILE => 'into-scalar', to => \$outfile;
38 ...
39 dispatcher close => 'into-scalar';
40 print $output;
41
42 =chapter DESCRIPTION
43 This basic file logger accepts an file-handle or filename as destination.
44
45 =chapter METHODS
46
47 =section Constructors
48
49 =c_method new TYPE, NAME, OPTIONS
50 =requires to FILENAME|FILEHANDLE|FILE-OBJECT
51 You can either specify a FILENAME, which is opened in append mode, or
52 any kind of handle or object which accepts supports C<print()>.
53 When cleaning-up the dispatcher, the file will only be closed in case
54 of a FILENAME.
55
56 =option charset STRING
57 =default charset 'utf-8'
58 Only used in combination with a FILENAME.
59
60 =option replace BOOLEAN
61 =default replace C<false>
62 Only used in combination with a FILENAME: throw away the old file
63 if it exists. Probably you wish to append to existing information.
64 =cut
65
66 sub init($)
67 { my ($self, $args) = @_;
68 $self->SUPER::init($args);
69 my $name = $self->name;
70 my $to = delete $args->{to}
71 or error __x"dispatcher {name} needs parameter 'to'", name => $name;
72
73 if(ref $to)
74 { $self->{output} = $to;
75 trace "opened dispatcher $name to a ".ref($to);
76 }
77 else
78 { $self->{filename} = $to;
79 my $mode = $args->{replace} ? '>' : '>>';
80 my $charset = delete $args->{charset} || 'utf-8';
81 my $binmode = "$mode:encoding($charset)";
82
83 $self->{output} = IO::File->new($to, $binmode)
84 or fault __x"cannot write log into {file} with {binmode}"
85 , binmode => $binmode, file => $to;
86
87 trace "opened dispatcher $name to $to with $binmode";
88 }
89
90 $self;
91 }
92
93 =method close
94 Only when initiated with a FILENAME, the file will be closed. In any
95 other case, nothing will be done.
96 =cut
97
98 sub close()
99 { my $self = shift;
100 $self->SUPER::close or return;
101 $self->{output}->close if $self->{filename};
102 $self;
103 }
104
105 =section Accessors
106
107 =method filename
108 Returns the name of the opened file, or C<undef> in case this dispatcher
109 was started from a file-handle or file-object.
110 =cut
111
112 sub filename() {shift->{filename}}
113
114 =section Logging
115 =cut
116
117 sub log($$$)
118 { my $self = shift;
119 $self->{output}->print($self->SUPER::translate(@_));
120 }
121
122 1;
+161
-0
lib/Log/Report/Dispatcher/Log4perl.pm less more
0 use warnings;
1 use strict;
2
3 package Log::Report::Dispatcher::Log4perl;
4 use base 'Log::Report::Dispatcher';
5
6 use Log::Report 'log-report', syntax => 'SHORT';
7 use Log::Report::Util qw/@reasons expand_reasons/;
8
9 use Log::Log4perl qw/:levels/;
10
11 my %default_reasonToLevel =
12 ( TRACE => $DEBUG
13 , ASSERT => $DEBUG
14 , INFO => $INFO
15 , NOTICE => $INFO
16 , WARNING => $WARN
17 , MISTAKE => $WARN
18 , ERROR => $ERROR
19 , FAULT => $ERROR
20 , ALERT => $FATAL
21 , FAILURE => $FATAL
22 , PANIC => $FATAL
23 );
24
25 @reasons != keys %default_reasonToLevel
26 and panic __"Not all reasons have a default translation";
27
28 =chapter NAME
29 Log::Report::Dispatcher::Log4perl - send messages to Log::Log4perl back-end
30
31 =chapter SYNOPSIS
32 dispatcher Log::Log4perl => 'logger', accept => 'NOTICE-'
33 , config => "$ENV{HOME}/.log.conf"
34 , to_level => [ 'ALERT-' => $ERROR ];
35
36 # disable default dispatcher
37 dispatcher close => 'logger';
38
39 # configuration inline, not in file: adapted from the Log4perl manpage
40 my $name = 'logger';
41 my $outfile = '/tmp/a.log';
42 my $config = <<__CONFIG;
43 log4perl.category.$name = INFO, Logfile
44 log4perl.appender.Logfile = Log::Log4perl::Appender::File
45 log4perl.appender.Logfile.filename = $outfn
46 log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout
47 log4perl.appender.Logfile.layout.ConversionPattern = %d %F{1} %L> %m
48 __CONFIG
49
50 dispatcher 'Log::Log4perl' => $name, config => \$config;
51
52 =chapter DESCRIPTION
53 This dispatchers produces output tot syslog, based on the C<Sys::Log4perl>
54 module (which will not be automatically installed for you).
55
56 The REASON for a message often uses names which are quite similar to the
57 log-levels used by M<Log::Dispatch>. However: they have a different
58 approach. The REASON of Log::Report limits the responsibility of the
59 programmer to indicate the cause of the message: whether it was able to
60 handle a certain situation. The Log::Dispatch levels are there for the
61 user's of the program. However: the programmer does not known anything
62 about the application (in the general case). This is cause of miuch of
63 the trickery in Perl programs.
64
65 The default translation table is list below. You can change the mapping
66 using M<new(to_level)>. See example in SYNOPSIS.
67
68 TRACE => $DEBUG ERROR => $ERROR
69 ASSERT => $DEBUG FAULT => $ERROR
70 INFO => $INFO ALERT => $FATAL
71 NOTICE => $INFO FAILURE => $FATAL
72 WARNING => $WARN PANIC => $FATAL
73 MISTAKE => $WARN
74
75
76 =chapter METHODS
77
78 =section Constructors
79
80 =c_method new TYPE, NAME, OPTIONS
81 The Log::Log4perl infrastructure has all information in a configuration
82 file. In that file, you should find a category with the NAME.
83
84 =option to_level ARRAY-of-PAIRS
85 =default to_level []
86 See M<reasonToLevel()>.
87
88 =requires config FILENAME|SCALAR
89 When a SCALAR reference is passed in, that must refer to a string which
90 contains the configuration text. Otherwise, specify an existing FILENAME.
91 =cut
92
93 sub init($)
94 { my ($self, $args) = @_;
95 $self->SUPER::init($args);
96
97 my $name = $self->name;
98 my $config = delete $args->{config}
99 or error __x"Log::Log4perl back-end {name} requires a 'config' parameter"
100 , name => $name;
101
102 $self->{level} = { %default_reasonToLevel };
103 if(my $to_level = delete $args->{to_level})
104 { my @to = @$to_level;
105 while(@to)
106 { my ($reasons, $level) = splice @to, 0, 2;
107 my @reasons = expand_reasons $reasons;
108
109 $level =~ m/^[0-5]$/
110 or error __x "Log::Log4perl level '{level}' must be in 0-5"
111 , level => $level;
112
113 $self->{level}{$_} = $level for @reasons;
114 }
115 }
116
117 Log::Log4perl->init($config);
118
119 $self->{appender} = Log::Log4perl->get_logger($name, %$args)
120 or error __x"cannot find logger '{name}' in configuration {config}"
121 , name => $name, config => $config;
122
123 $self;
124 }
125
126 sub close()
127 { my $self = shift;
128 $self->SUPER::close or return;
129 delete $self->{backend};
130 $self;
131 }
132
133 =section Accessors
134
135 =method appender
136 Returns the M<Log::Log4perl::Logger> object which is used for logging.
137 =cut
138
139 sub appender() {shift->{appender}}
140
141 =section Logging
142 =cut
143
144 sub log($$$$)
145 { my $self = shift;
146 my $text = $self->SUPER::translate(@_) or return;
147 my $level = $self->reasonToLevel($_[1]);
148
149 $self->appender->log($level, $text);
150 $self;
151 }
152
153 =method reasonToLevel REASON
154 Returns a level which is understood by Log::Dispatch, based on
155 a translation table. This can be changed with M<new(to_level)>.
156 =cut
157
158 sub reasonToLevel($) { $_[0]->{level}{$_[1]} }
159
160 1;
+150
-0
lib/Log/Report/Dispatcher/LogDispatch.pm less more
0 use warnings;
1 use strict;
2
3 package Log::Report::Dispatcher::LogDispatch;
4 use base 'Log::Report::Dispatcher';
5
6 use Log::Report 'log-report', syntax => 'SHORT';
7 use Log::Report::Util qw/@reasons expand_reasons/;
8
9 use Log::Dispatch 2.00;
10
11 my %default_reasonToLevel =
12 ( TRACE => 'debug'
13 , ASSERT => 'debug'
14 , INFO => 'info'
15 , NOTICE => 'notice'
16 , WARNING => 'warning'
17 , MISTAKE => 'warning'
18 , ERROR => 'error'
19 , FAULT => 'error'
20 , ALERT => 'alert'
21 , FAILURE => 'emergency'
22 , PANIC => 'critical'
23 );
24
25 @reasons != keys %default_reasonToLevel
26 and panic __"Not all reasons have a default translation";
27
28 =chapter NAME
29 Log::Report::Dispatcher::LogDispatch - send messages to Log::Dispatch back-end
30
31 =chapter SYNOPSIS
32 use Log::Dispatch::File;
33 dispatcher Log::Dispatch::File => 'logger', accept => 'NOTICE-'
34 , to_level => [ 'ALERT-' => 'err' ];
35
36 # disable default dispatcher
37 dispatcher close => 'logger';
38
39 =chapter DESCRIPTION
40 This dispatchers produces output to and C<Log::Dispatch> back-end.
41 (which will NOT be automatically installed for you).
42
43 The REASON for a message often uses names which are quite similar to the
44 log-levels used by M<Log::Dispatch>. However: they have a different
45 approach. The REASON of Log::Report limits the responsibility of the
46 programmer to indicate the cause of the message: whether it was able to
47 handle a certain situation. The Log::Dispatch levels are there for the
48 user's of the program. However: the programmer does not known anything
49 about the application (in the general case). This is cause of miuch of
50 the trickery in Perl programs.
51
52 The default translation table is list below. You can change the mapping
53 using M<new(to_level)>. See example in SYNOPSIS.
54
55 =chapter METHODS
56
57 =section Constructors
58
59 =c_method new TYPE, NAME, OPTIONS
60 The Log::Dispatch infrastructure has quite a large number of output
61 TYPEs, each extending the M<Log::Dispatch::Output> base-class. You
62 do not create these objects yourself: Log::Report is doing it for you.
63
64 The Log::Dispatch back-ends are very careful with validating their
65 parameters, so you will need to restrict the options to what is supported
66 for the specific back-end. See their respective manual-pages. The errors
67 produced by the back-ends quite horrible and untranslated, sorry.
68
69 =option to_level ARRAY-of-PAIRS
70 =default to_level []
71 See M<reasonToLevel()>.
72
73 =option min_level LEVEL
74 =default min_level C<debug>
75 Restrict the messages which are passed through based on the LEVEL,
76 so after the reason got translated into a Log::Dispatch compatible
77 LEVEL. The default will use Log::Report restrictions only.
78
79 =option max_level LEVEL
80 =default max_level C<undef>
81 Like C<min_level>.
82
83 =option callbacks CODE|ARRAY-of-CODE
84 =default callbacks []
85 See M<Log::Dispatch::Output>.
86
87 =cut
88
89 sub init($)
90 { my ($self, $args) = @_;
91 $self->SUPER::init($args);
92
93 $args->{name} = $self->name;
94 $args->{min_level} ||= 'debug';
95
96 $self->{level} = { %default_reasonToLevel };
97 if(my $to_level = delete $args->{to_level})
98 { my @to = @$to_level;
99 while(@to)
100 { my ($reasons, $level) = splice @to, 0, 2;
101 my @reasons = expand_reasons $reasons;
102
103 Log::Dispatch->level_is_valid($level)
104 or error __x"Log::Dispatch level '{level}' not understood"
105 , level => $level;
106
107 $self->{level}{$_} = $level for @reasons;
108 }
109 }
110
111 $self->{backend} = $self->type->new(%$args);
112 $self;
113 }
114
115 sub close()
116 { my $self = shift;
117 $self->SUPER::close or return;
118 delete $self->{backend};
119 $self;
120 }
121
122 =section Accessors
123
124 =method backend
125 Returns the M<Log::Dispatch::Output> object which is used for logging.
126 =cut
127
128 sub backend() {shift->{backend}}
129
130 =section Logging
131 =cut
132
133 sub log($$$$)
134 { my $self = shift;
135 my $text = $self->SUPER::translate(@_) or return;
136 my $level = $self->reasonToLevel($_[1]);
137
138 $self->backend->log(level => $level, message => $text);
139 $self;
140 }
141
142 =method reasonToLevel REASON
143 Returns a level which is understood by Log::Dispatch, based on
144 a translation table. This can be changed with M<new(to_level)>.
145 =cut
146
147 sub reasonToLevel($) { $_[0]->{level}{$_[1]} }
148
149 1;
+143
-0
lib/Log/Report/Dispatcher/Syslog.pm less more
0 use warnings;
1 use strict;
2
3 package Log::Report::Dispatcher::Syslog;
4 use base 'Log::Report::Dispatcher';
5
6 use Sys::Syslog 0.11, qw/:standard :macros/;
7 use Log::Report 'log-report', syntax => 'SHORT';
8 use Log::Report::Util qw/@reasons expand_reasons/;
9
10 use File::Basename qw/basename/;
11
12 my %default_reasonToPrio =
13 ( TRACE => LOG_DEBUG
14 , ASSERT => LOG_DEBUG
15 , INFO => LOG_INFO
16 , NOTICE => LOG_NOTICE
17 , WARNING => LOG_WARNING
18 , MISTAKE => LOG_WARNING
19 , ERROR => LOG_ERR
20 , FAULT => LOG_ERR
21 , ALERT => LOG_ALERT
22 , FAILURE => LOG_EMERG
23 , PANIC => LOG_CRIT
24 );
25
26 @reasons != keys %default_reasonToPrio
27 and panic __"Not all reasons have a default translation";
28
29 =chapter NAME
30 Log::Report::Dispatcher::Syslog - send messages to syslog
31
32 =chapter SYNOPSIS
33 dispatcher SYSLOG => 'syslog', accept => 'NOTICE-'
34 , to_prio => [ 'ALERT-' => 'err' ];
35
36 # disable default dispatcher
37 dispatcher close => 'syslog';
38
39 =chapter DESCRIPTION
40 This dispatchers produces output to syslog, based on the M<Sys::Syslog>
41 module (which will NOT be automatically installed for you).
42
43 The REASON for a message often uses names which are quite similar to
44 the log-levels used by syslog. However: they have a different purpose.
45 The REASON is used by the programmer to indicate the cause of the message:
46 whether it was able to handle a certain situation. The syslog levels
47 are there for the user's of the program (with syslog usually the
48 system administrators). It is not unusual to see a "normal" error
49 or mistake as a very serious situation in a production environment. So,
50 you may wish to translate any message above reason MISTAKE into a LOG_CRIT.
51
52 The default translation table is list below. You can change the mapping
53 using M<new(to_prio)>. See example in SYNOPSIS.
54
55 TRACE => LOG_DEBUG ERROR => LOG_ERR
56 ASSERT => LOG_DEBUG FAULT => LOG_ERR
57 INFO => LOG_INFO ALERT => LOG_ALERT
58 NOTICE => LOG_NOTICE FAILURE => LOG_EMERG
59 WARNING => LOG_WARNING PANIC => LOG_CRIT
60 MISTAKE => LOG_WARNING
61
62 =chapter METHODS
63
64 =section Constructors
65
66 =c_method new TYPE, NAME, OPTIONS
67
68 =option identity STRING
69 =default identity <basename $0>
70
71 =option flags STRING
72 =default flags 'pid,nowait'
73 Any combination of C<pid>, C<ndelay>, and C<nowait>, used with
74 C<openlog(3)> if needed
75
76 =option facility STRING
77 =default facility 'user'
78 The possible values for this depend (a little) on the system. POSIX
79 only defines 'user' and 'local0' upto 'local7'.
80
81 =option to_prio ARRAY-of-PAIRS
82 =default to_prio []
83 See M<reasonToPrio()>.
84
85 =cut
86
87 sub init($)
88 { my ($self, $args) = @_;
89 $self->SUPER::init($args);
90
91 my $ident = delete $args->{identity} || basename $0;
92 my $flags = delete $args->{flags} || 'pid,nowait';
93 my $fac = delete $args->{facility} || 'user';
94 openlog $ident, $flags, $fac; # doesn't produce error.
95
96 $self->{prio} = { %default_reasonToPrio };
97 if(my $to_prio = delete $args->{to_prio})
98 { my @to = @$to_prio;
99 while(@to)
100 { my ($reasons, $level) = splice @to, 0, 2;
101 my @reasons = expand_reasons $reasons;
102
103 my $prio = Sys::Syslog::xlate($level);
104 error __x"syslog level '{level}' not understood", level => $level
105 if $prio eq -1;
106
107 $self->{prio}{$_} = $prio for @reasons;
108 }
109 }
110
111 $self;
112 }
113
114 sub close()
115 { my $self = shift;
116 closelog;
117 $self->SUPER::close;
118 }
119
120 =section Accessors
121
122 =section Logging
123 =cut
124
125 sub log($$$$)
126 { my $self = shift;
127 my $text = $self->SUPER::translate(@_) or return;
128 my $prio = $self->reasonToPrio($_[1]);
129
130 # handle each line in message separately
131 syslog $prio, "%s", $_
132 for split /\n/, $text;
133 }
134
135 =method reasonToPrio REASON
136 Returns a level which is understood by syslog(3), based on a translation
137 table. This can be changed with M<new(to_prio)>.
138 =cut
139
140 sub reasonToPrio($) { $_[0]->{prio}{$_[1]} }
141
142 1;
+163
-0
lib/Log/Report/Dispatcher/Try.pm less more
0 use warnings;
1 use strict;
2
3 package Log::Report::Dispatcher::Try;
4 use base 'Log::Report::Dispatcher';
5
6 use Log::Report 'log-report', syntax => 'SHORT';
7 use Log::Report::Exception;
8
9 =chapter NAME
10 Log::Report::Dispatcher::Try - capture all reports as exceptions
11
12 =chapter SYNOPSIS
13 try { ... }
14 print ref $@; # Log::Report::Dispatcher::Try
15
16 =chapter DESCRIPTION
17
18 =chapter OVERLOADING
19
20 =overload boolean
21 Returns true if the previous try block did produce a terminal
22 error. This "try" object is assigned to C<$@>, and the usual
23 perl syntax is C<if($@) {...error-handler...}>.
24
25 =overload stringify
26 When C<$@> is used the traditional way, it is checked to have
27 a string content. In this case, stringify into the fatal error
28 or nothing.
29 =cut
30
31 use overload
32 bool => 'failed'
33 , '""' => 'printError';
34
35 =chapter METHODS
36
37 =section Constructors
38
39 =c_method new TYPE, NAME, OPTIONS
40 =option exceptions ARRAY-of-EXCEPTIONS
41 =default exceptions []
42
43 =option died STRING
44 =default died C<undef>
45 The exit string ($@) of the eval'ed block.
46 =cut
47
48 sub init($)
49 { my ($self, $args) = @_;
50 $self->SUPER::init($args);
51 $self->{exceptions} = delete $args->{exceptions} || [];
52 $self->{died} = delete $args->{died};
53 $self;
54 }
55
56 =method close
57 Only when initiated with a FILENAME, the file will be closed. In any
58 other case, nothing will be done.
59 =cut
60
61 sub close()
62 { my $self = shift;
63 $self->SUPER::close or return;
64 $self;
65 }
66
67 =section Accessors
68
69 =method died [STRING]
70 The message which was reported by C<eval>, which is used internally
71 to catch problems in the try block.
72 =cut
73
74 sub died(;$)
75 { my $self = shift;
76 @_ ? ($self->{died} = shift) : $self->{died};
77 }
78
79 =method exceptions
80 Returns all collected C<Log::Report::Exceptions>. The last of
81 them may be a fatal one. The other are non-fatal.
82 =cut
83
84 sub exceptions() { @{shift->{exceptions}} }
85
86 =section Logging
87
88 =method log OPTS, REASON, MESSAGE
89 Other dispatchers translate the message here, and make it leave
90 the program. However, messages in a "try" block are only
91 captured in an intermediate layer: they may never be presented
92 to an end-users. And for sure, we do not know the language yet.
93
94 The MESSAGE is either a STRING or a M<Log::Report::Message>.
95 =cut
96
97 sub log($$$)
98 { my ($self, $opts, $reason, $message) = @_;
99
100 # If "try" does not want a stack, because of its mode,
101 # then don't produce one later! (too late)
102 $opts->{stack} ||= [];
103 $opts->{location} ||= '';
104
105 push @{$self->{exceptions}},
106 Log::Report::Exception->new
107 ( reason => $reason
108 , report_opts => $opts
109 , message => $message
110 );
111
112 $self;
113 }
114
115 =method reportAll
116 Re-cast the messages in all collect exceptions into the defined
117 dispatchers, which were disabled during the try block.
118 =cut
119
120 sub reportAll() { $_->throw for shift->exceptions }
121
122 =method reportFatal
123 Re-cast only the fatal message to the defined dispatchers. If the
124 block was left without problems, then nothing will be done.
125 =cut
126
127 sub reportFatal() { $_->throw for shift->wasFatal }
128
129 =section Status
130
131 =method failed
132 Returns true if the block was left with an fatal message.
133
134 =method success
135 Returns true if the block exited normally.
136 =cut
137
138 sub failed() { shift->{died}}
139 sub success() { ! shift->{died}}
140
141 =method wasFatal
142 Returns the M<Log::Report::Exception> which caused the "try" block to
143 die, otherwise an empty LIST (undef).
144 =cut
145
146 sub wasFatal()
147 { my $self = shift;
148 $self->{died} ? $self->{exceptions}[-1] : ();
149 }
150
151 =method printError
152 If this object is kept in C<$@>, and someone uses this as string, we
153 want to show the fatal error message.
154 =cut
155
156 sub printError()
157 { my $fatal = shift->wasFatal or return '';
158 # don't use '.', because it is overloaded for message
159 join('', $fatal->reason, ': ', $fatal->message, "\n");
160 }
161
162 1;
+541
-0
lib/Log/Report/Dispatcher.pm less more
0 use warnings;
1 use strict;
2
3 package Log::Report::Dispatcher;
4
5 use Log::Report 'log-report', syntax => 'SHORT';
6 use Log::Report::Util qw/parse_locale expand_reasons %reason_code
7 escape_chars/;
8
9 use POSIX qw/strerror locale_h/;
10 use List::Util qw/sum/;
11
12 my %modes = (NORMAL => 0, VERBOSE => 1, ASSERT => 2, DEBUG => 3
13 , 0 => 0, 1 => 1, 2 => 2, 3 => 3);
14 my @default_accept = ('NOTICE-', 'INFO-', 'ASSERT-', 'ALL');
15
16 my %predef_dispatchers = map { (uc($_) => __PACKAGE__.'::'.$_) }
17 qw/File Syslog Try/;
18
19 =chapter NAME
20 Log::Report::Dispatcher - manage dispatching
21
22 =chapter SYNOPSIS
23 use Log::Report;
24 dispatcher 'FILE', 'log'
25 , mode => 'DEBUG', to => '/var/log/mydir/myfile';
26
27 # The follow will be created for you always (when STDERR leads
28 # to a terminal). Full package name is used, same as 'FILE'
29 dispatcher Log::Report::Dispatch::File => 'stderr'
30 , to => \*STDERR, accept => 'NOTICE-';
31
32 # Within a "try" block, there is only one dispatcher
33 dispatcher TRY => 'try';
34
35 =chapter DESCRIPTION
36 This base-class handles the creation of dispatchers, plus the
37 common filtering rules.
38
39 When the program sees a terminal on STDERR (the usual case for any
40 non-daemon), it will create a dispatcher for you to show all messages
41 with minimal level NOTICE to it. That dispatcher is named 'stderr',
42 and when you create one with the same name yourself, it will replace
43 the default one.
44
45 See the L</DETAILS> section, below.
46
47 =chapter METHODS
48
49 =section Constructors
50
51 =c_method new TYPE, NAME, OPTIONS
52 Create a dispatcher. The TYPE of back-end to start is required, and listed
53 in the L</DESCRIPTION> part of this manual-page. For various external
54 back-ends, special wrappers are created.
55
56 The NAME must be uniquely identifying this dispatcher. When a second
57 dispatcher is created (via M<Log::Report::dispatcher()>) with the name
58 of an existing dispatcher, the existing one will get replaced.
59
60 All OPTIONS which are not consumed by this base constructor are passed
61 to the wrapped back-end. Some of them will check whether all OPTIONS
62 are understood, other ignore unknown OPTIONS.
63
64 =option accept REASONS
65 =default accept C<depend on mode>
66 See M<Log::Report::Util::expand_reasons()> for possible values. If
67 the initial mode for this dispatcher does not need verbose or debug
68 information, then those levels will not be accepted.
69
70 When the mode equals C<NORMAL> (the default) then C<accept>'s default
71 is C<NOTICE->. In case of C<VERBOSE> it will be C<INFO->, C<ASSERT>
72 results in C<ASSERT->, and C<DEBUG> in C<ALL>.
73
74 =option locale LOCALE
75 =default locale <system locale>
76 Overrules the global setting. Can be overruled by
77 M<Log::Report::report(locale)>.
78
79 =option mode 'NORMAL'|'VERBOSE'|'ASSERT'|'DEBUG'|0..3
80 =default mode 'NORMAL'
81 Possible values are C<NORMAL> (or C<0> or C<undef>), which will not show
82 C<INFO> or debug messages, C<VERBOSE> (C<1>; shows C<INFO> not debug),
83 C<ASSERT> (C<2>; only ignores C<TRACE> messages), or C<DEBUG> (C<3>)
84 which shows everything. See section L<Log::Report/Run modes>.
85
86 You are adviced to use the symbolic mode names when the mode is
87 changed within your program: the numerical values are available
88 for smooth M<Getopt::Long> integration.
89 =cut
90
91 sub new(@)
92 { my ($class, $type, $name, %args) = @_;
93
94 my $backend
95 = $predef_dispatchers{$type} ? $predef_dispatchers{$type}
96 : $type->isa('Log::Dispatch::Output')
97 ? __PACKAGE__.'::LogDispatch' # wrapper initializer
98 : $type->isa('Log::Log4perl')
99 ? __PACKAGE__.'::Log4perl' # wrapper initializer
100 : $type;
101
102 eval "require $backend";
103 $@ and alert "cannot use class $backend:\n$@";
104
105 (bless {name => $name, type => $type, filters => []}, $backend)
106 ->init(\%args);
107 }
108
109 sub init($)
110 { my ($self, $args) = @_;
111 my $mode = $self->_set_mode(delete $args->{mode} || 'NORMAL');
112
113 $self->{locale} = delete $args->{locale};
114
115 my $accept = delete $args->{accept} || $default_accept[$mode];
116 $self->{needs} = [ expand_reasons $accept ];
117 $self;
118 }
119
120 =method close
121 Terminate the dispatcher's activities. The dispatcher gets disabled,
122 to avoid the case that it is accidentally used. Returns C<undef> (false)
123 if the dispatcher was already closed.
124 =cut
125
126 sub close()
127 { my $self = shift;
128 $self->{closed}++ and return undef;
129 $self->{disabled}++;
130 $self;
131 }
132
133 DESTROY() { shift->close }
134
135 =section Accessors
136
137 =method name
138 Returns the unique name of this dispatcher.
139 =cut
140
141 sub name {shift->{name}}
142
143 =method type
144 The dispatcher TYPE, which is usually the same as the class of this
145 object, but not in case of wrappers like for Log::Dispatch.
146 =cut
147
148 sub type() {shift->{type}}
149
150 =method mode
151 Returns the mode in use for the dispatcher as number. See M<new(mode)>
152 and L<Log::Report/Run modes>.
153 =cut
154
155 sub mode() {shift->{mode}}
156
157 # only to be used via Log::Report::dispatcher(mode => ...)
158 # because requires re-investigating needs
159 sub _set_mode($)
160 { my $self = shift;
161 my $mode = $self->{mode} = $modes{$_[0]};
162 defined $mode
163 or error __x"unknown run mode '{mode}'", mode => $_[0];
164
165 info __x"switching to run mode {mode}", mode => $mode;
166 $mode;
167 }
168
169 # only to be called from Log::Report::dispatcher()!!
170 # because requires re-investigating needs
171 sub _disable($)
172 { my $self = shift;
173 @_ ? ($self->{disabled} = shift) : $self->{disabled};
174 }
175
176 =method isDisabled
177 =method needs
178 Returns the list with all REASONS which are needed to fulfil this
179 dispatcher's needs. When disabled, the list is empty, but not forgotten.
180 =cut
181
182 sub isDisabled() {shift->{disabled}}
183 sub needs() { $_[0]->{disabled} ? () : @{$_[0]->{needs}} }
184
185 =section Logging
186
187 =method log HASH-of-OPTIONS, REASON, MESSAGE
188 This method is called by M<Log::Report::report()> and should not be called
189 directly. Internally, it will call M<translate()>, which does most of
190 the work.
191 =cut
192
193 sub log($$$)
194 { panic "method log() must be extended per back-end";
195 }
196
197 =method translate HASH-of-OPTIONS, REASON, MESSAGE
198 See L</Processing the message>, which describes the actions taken by
199 this method. A string is returned, which ends on a new-line, and
200 may be multi-line (in case a stack trace is produced).
201 =cut
202
203 my %always_loc = map {($_ => 1)} qw/ASSERT WARNING PANIC/;
204 sub translate($$$)
205 { my ($self, $opts, $reason, $message) = @_;
206
207 my $mode = $self->{mode};
208 my $code = $reason_code{$reason}
209 or panic "unknown reason '$reason'";
210
211 my $show_loc
212 = $always_loc{$reason}
213 || ($mode==2 && $code >= $reason_code{WARNING})
214 || ($mode==3 && $code >= $reason_code{MISTAKE});
215
216 my $show_stack
217 = $reason eq 'PANIC'
218 || ($mode==2 && $code >= $reason_code{ALERT})
219 || ($mode==3 && $code >= $reason_code{ERROR});
220
221 my $translate = defined $message->msgid;
222 my $locale = $translate ? ($opts->{locale} || $self->{locale}) : 'en_US';
223 my $loc = defined $locale ? setlocale(LC_ALL, $locale) : undef;
224
225 my $text;
226 if($translate)
227 { $text = (__$reason)->toString. ': '. $message->toString;
228 $text .= ': ' . strerror($opts->{errno}) if $opts->{errno};
229 $text .= "\n";
230 }
231 else
232 { $text = $reason . ': ' . $message->untranslated;
233 $text .= ': '. strerror($opts->{errno}) if $opts->{errno};
234 $text .= "\n";
235 }
236
237 if($show_stack)
238 { my $stack = $opts->{stack} ||= $self->collectStack;
239
240 foreach (@$stack)
241 { $text .= $_->[0] . " " .
242 ( $translate
243 ? __x( 'at {filename} line {line}'
244 , filename => $_->[1], line => $_->[2] )
245 : "at $_->[1] line $_->[2]"
246 ) . "\n";
247 }
248 }
249 elsif($show_loc)
250 { my $loc = $opts->{location} ||= $self->collectLocation;
251 my ($pkg, $fn, $line, $sub) = @$loc;
252 $text .= " " .
253 ( $translate
254 ? __x('at {filename} line {line}', filename => $fn, line => $line)
255 : "at $fn line $line"
256 ) . "\n";
257 }
258
259 setlocale(LC_ALL, $loc)
260 if defined $loc;
261
262 $text;
263 }
264
265 =method collectStack [MAXDEPTH]
266 Returns an ARRAY of ARRAYs with text, filename, line-number.
267 =cut
268
269 sub collectStack($)
270 { my ($self, $max) = @_;
271
272 my ($nest, $sub) = (1, undef);
273 $sub = (caller $nest++)[3]
274 while defined $sub && $sub ne 'Log::Report::report';
275
276 # skip syntax==SHORT routine entries
277 $nest++ if defined $sub && $sub =~ m/^Log\:\:Report\:\:/;
278
279 # special trick by Perl for Carp::Heavy: adds @DB::args
280 { package DB; # non-blank before package to avoid problem with OODoc
281
282 my @stack;
283 while(!defined $max || $max--)
284 { my ($pkg, $fn, $linenr, $sub) = caller $nest++;
285 defined $pkg or last;
286
287 my $line = $self->stackTraceLine(call => $sub, params => \@DB::args);
288 push @stack, [$line, $fn, $linenr];
289 }
290
291 \@stack;
292 }
293 }
294
295 =method collectLocation
296 Collect the information to be displayed as line where the error occurred.
297 Probably, this needs improvement, where carp and die show different lines.
298 =cut
299
300 sub collectLocation()
301 { my $self = shift;
302 my $nest = 1;
303 my @args;
304
305 do {@args = caller $nest++}
306 until $args[3] eq 'Log::Report::report'; # sub
307
308 # skip syntax==SHORT routine entries
309 @args = caller $nest++
310 if +(caller $nest)[3] =~ m/^Log\:\:Report\:\:/;
311
312 \@args;
313 }
314
315 =ci_method stackTraceLine OPTIONS
316 =requires package CLASS
317 =requires filename STRING
318 =requires linenr INTEGER
319 =requires call STRING
320 =requires params ARRAY
321
322 =option max_line INTEGER
323 =default max_line C<undef>
324
325 =option max_params INTEGER
326 =default max_params 8
327
328 =option abstract INTEGER
329 =default abstract 1
330 The higher the abstraction value, the less details are given
331 about the caller. The minimum abstraction is specified, and
332 then increased internally to make the line fit within the C<max_line>
333 margin.
334 =cut
335
336 sub stackTraceLine(@)
337 { my ($thing, %args) = @_;
338
339 my $max = $args{max_line} ||= 500;
340 my $abstract = $args{abstract} || 1;
341 my $maxparams = $args{max_params} || 8;
342 my @params = @{$args{params}};
343 my $call = $args{call};
344
345 my $obj = ref $params[0] && $call =~ m/^(.*\:\:)/ && $params[0]->isa($1)
346 ? shift @params : undef;
347
348 my $listtail = '';
349 if(@params > $maxparams)
350 { $listtail = ', [' . (@params-$maxparams) . ' more]';
351 $#params = $maxparams -1;
352 }
353
354 $max -= @params * 2 - length($listtail); # \( ( \,[ ] ){n-1} \)
355
356 my $calling = $thing->stackTraceCall(\%args, $abstract, $call, $obj);
357 my @out = map {$thing->stackTraceParam(\%args, $abstract, $_)} @params;
358 my $total = sum map {length $_} $calling, @out;
359
360 ATTEMPT:
361 while($total <= $max)
362 { $abstract++;
363 last if $abstract > 2; # later more levels
364
365 foreach my $p (reverse 0..$#out)
366 { my $old = $out[$p];
367 $out[$p] = $thing->stackTraceParam(\%args, $abstract, $params[$p]);
368 $total -= length($old) - length($out[$p]);
369 last ATTEMPT if $total <= $max;
370 }
371
372 my $old = $calling;
373 $calling = $thing->stackTraceCall(\%args, $abstract, $call, $obj);
374 $total -= length($old) - length($calling);
375 }
376
377 $calling .'(' . join(', ',@out) . $listtail . ')';
378 }
379
380 # 1: My::Object(0x123141, "my string")
381 # 2: My::Object=HASH(0x1231451)
382 # 3: My::Object("my string")
383 # 4: My::Object()
384 #
385
386 sub stackTraceCall($$$;$)
387 { my ($thing, $args, $abstract, $call, $obj) = @_;
388
389 if(defined $obj) # object oriented
390 { my ($pkg, $method) = $call =~ m/^(.*\:\:)(.*)/;
391 return overload::StrVal($obj) . '->' . $call;
392 }
393 else # imperative
394 { return $call;
395 }
396 }
397
398 sub stackTraceParam($$$)
399 { my ($thing, $args, $abstract, $param) = @_;
400
401 return $param # int or float
402 if $param =~ /^[+-]?(?:\d+(?:\.\d*)?|\.\d+)(?:[eE][+-]?\d+)?$/;
403
404 return overload::StrVal($param)
405 if ref $param;
406
407 '"' . escape_chars($param) . '"';
408 }
409
410 =chapter DETAILS
411
412 =section Available back-ends
413
414 When a dispatcher is created (via M<new()> or M<Log::Report::dispatcher()>),
415 you must specify the TYPE of the dispatcher. This can either be a class
416 name, which extends a M<Log::Report::Dispatcher>, or a pre-defined
417 abbrevation of a class name. Implemented are:
418
419 =over 4
420 =item M<Log::Report::Dispatcher::File> (abbreviation 'FILE')
421 Logs the message into a file, which can either be opened by the
422 class or be opened before the dispatcher is created.
423
424 =item M<Log::Report::Dispatcher::Syslog> (abbreviation 'SYSLOG')
425 Send messages into the system's syslog infrastructure, using
426 M<Sys::Syslog>.
427
428 =item C<Log::Dispatch::*>
429 All of the M<Log::Dispatch::Output> extensions can be used directly.
430 The M<Log::Report::Dispatcher::LogDispatch> will wrap around that
431 back-end.
432
433 =item C<Log::Log4perl>
434 Use the M<Log::Log4perl> main object to write to dispatchers. This
435 infrastructure uses a configuration file.
436
437 =item M<Log::Report::Dispatcher::Try> (abbreviation 'TRY')
438 Used by M<Log::Report::try()>, it will translate reports into
439 exceptions.
440
441 =back
442
443 =section Processing the message
444
445 =subsection Addition information
446
447 The modules which use C<Log::Report> will only specify the base of
448 the message string. The base dispatcher and the back-ends will extend
449 this message with additional information:
450
451 =over 4
452 =item . the reason
453 =item . the filename/line-number where the problem appeared
454 =item . the filename/line-number where it problem was reported
455 =item . the error text in C<$!>
456 =item . a stack-trace
457 =item . a trailing new-line
458 =back
459
460 When the message is a translatable object (M<Log::Report::Message>, for
461 instance created with M<Log::Report::__()>), then the added components
462 will get translated as well. Otherwise, all will be in English.
463
464 Exactly what will be added depends on the actual mode of the dispatcher
465 (change it with M<mode()>, initiate it with M<new(mode)>).
466
467 mode mode mode mode block
468 REASON SOURCE TE! NORM -v -vv -vvv TRY
469 trace program ... S
470 assert program ... SL SL
471 info program T.. S S S
472 notice program T.. S S S S D
473 mistake user T.. S S S SL D
474 warning program T.! SL SL SL SL DL
475 error user TE. S S SL SC B
476 fault system TE! S S SL SC B
477 alert system T.! S S SC SC S
478 failure system TE! S S SC SC S
479 panic program .E. SC SC SC SC SC
480
481 -v = verbose, -vv = debug, -vvv = trace
482 T - usually translated
483 E - exception
484 ! - will include $! text
485 B - leave block with exception
486 D - delayed; only shown when block completes without error
487 L - include filename and linenumber
488 S - show/print when accepted
489 C - stack trace (like Carp::confess())
490
491 =subsection Filters
492
493 With a filter, you can block or modify specific messages before
494 translation. There may be a wish to change the REASON of a report
495 or its content. It is not possible to avoid the exit which is
496 related to the original message, because a module's flow depends
497 on it to happen.
498
499 When there are filters defined, they will be called in order of
500 definition. For each of the dispatchers which are called for a
501 certain REASON (which C<accept> that REASON), it is checked whether
502 its name is listed for the filter (when no names where specified,
503 then the filter is applied to all dispatchers).
504
505 When selected, the filter's CODE reference is called with four arguments:
506 the dispatcher object (a M<Log::Report::Dispatcher>), the HASH-of-OPTIONS
507 passed as optional first argument to M<Log::Report::report()>, the
508 REASON, and the MESSAGE. Returned is the new REASON and MESSAGE.
509 When the returned REASON is C<undef>, then the message will be ignored
510 for that dispatcher.
511
512 Be warned about processing the MESSAGE: it is a M<Log::Report::Message>
513 object which may have a C<prepend> string and C<append> string or
514 object. When the call to M<Log::Report::report()> contained multiple
515 comma-separated components, these will already have been joined together
516 using concatenation (see M<Log::Report::Message::concat()>.
517
518 =example a filter on syslog
519 dispatcher filter => \&myfilter, 'syslog';
520
521 # ignore all translatable and non-translatable messages containing
522 # the word "skip"
523 sub myfilter($$$$)
524 { my ($disp, $opts, $reason, $message) = @_;
525 return () if $message->untranslated =~ m/\bskip\b/;
526 ($reason, $message);
527 }
528
529 =example take all mistakes and warnings serious
530 dispatch filter => \&take_warns_serious;
531 sub take_warns_serious($$$$)
532 { my ($disp, $opts, $reason, $message) = @_;
533 $reason eq 'MISTAKE' ? (ERROR => $message)
534 : $reason eq 'WARNING' ? (FAULT => $message)
535 : ($reason => $message);
536 }
537
538 =cut
539
540 1;
+72
-0
lib/Log/Report/Exception.pm less more
0 use warnings;
1 use strict;
2
3 package Log::Report::Exception;
4
5 use Log::Report 'log-report';
6 use POSIX qw/locale_h/;
7
8 =chapter NAME
9 Log::Report::Exception - a collected report
10
11 =chapter SYNOPSIS
12 # created within a try block
13 try { error "help!" };
14 my $exception = $@->wasFatal;
15 $exception->throw if $exception;
16
17 $@->reportFatal; # combination of above two lines
18
19 =chapter DESCRIPTION
20 In Log::Report, exceptions are not as extended as available in
21 languages as Java: you do not create classes for them. The only
22 thing an exception object does, is capture some information about
23 an (untranslated) report.
24
25 =chapter OVERLOADING
26
27 =chapter METHODS
28
29 =section Constructors
30 =c_method new OPTIONS, VARIABLES
31
32 =option report_opts HASH
33 =default report_opts {}
34
35 =requires reason REASON
36 =requires message Log::Report::Message
37 =cut
38
39 sub new($@)
40 { my ($class, %args) = @_;
41 $args{report_opts} ||= {};
42 bless \%args, $class;
43 }
44
45 =section Accessors
46
47 =method report_opts
48 =method reason
49 =method message
50 =cut
51
52 sub report_opts() {shift->{report_opts}}
53 sub reason() {shift->{reason}}
54 sub message() {shift->{message}}
55
56 =section Reporting Exceptions
57
58 =method throw OPTIONS
59 Insert the message contained in the exception into the currently
60 defined dispatchers. The C<throw> name is commonly known
61 exception related terminology for C<report>.
62 =cut
63
64 # if we would used "report" here, we get a naming conflict with
65 # function Log::Report::report.
66 sub throw(@)
67 { my $self = shift;
68 report $self->{report_opts}, $self->reason, $self->message;
69 }
70
71 1;
+338
-0
lib/Log/Report/Extract/PerlPPI.pm less more
0
1 use warnings;
2 use strict;
3
4 package Log::Report::Extract::PerlPPI;
5
6 use Log::Report 'log-report', syntax => 'SHORT';
7
8 use Log::Report::Lexicon::Index ();
9 use Log::Report::Lexicon::POT ();
10
11 use PPI;
12
13 # See Log::Report translation markup functions
14 my %msgids =
15 # MSGIDs COUNT OPTS VARS SPLIT
16 ( __ => [1, 0, 0, 0, 0]
17 , __x => [1, 0, 1, 1, 0]
18 , __xn => [2, 1, 1, 1, 0]
19 , __n => [2, 1, 1, 0, 0]
20 , N__ => [1, 0, 1, 1, 0] # may be used with opts/vars
21 , N__n => [2, 0, 1, 1, 0] # idem
22 , N__w => [1, 0, 0, 0, 1]
23 );
24
25 =chapter NAME
26 Log::Report::Extract::PerlPPI - Collect translatable strings from Perl using PPI
27
28 =chapter SYNOPSIS
29 my $ppi = Log::Report::Extract::PerlPPI->new
30 ( lexicon => '/usr/share/locale'
31 );
32 $ppi->process('lib/My/Pkg.pm'); # many times
33 $ppi->showStats; # to dispatchers which accept TRACE or INFO
34 $ppi->write; # also cleans processing memory.
35
36 =chapter DESCRIPTION
37 This module helps maintaining the POT files, updating the list of
38 message-ids which are kept in them. After initiation, the M<process()>
39 method needs to be called with all files which changed since last processing
40 and the existing PO files will get updated accordingly. If no translations
41 exist yet, one C<textdomain/xx.po> file will be created.
42
43 =chapter METHODS
44
45 =section Constructors
46
47 =c_method new OPTIONS
48 =requires lexicon DIRECTORY
49 The place where the lexicon is kept. When no lexicon is defined yet,
50 this will be the directory where an C<domain/xx.po> file will be created.
51
52 =option charset STRING
53 =default charset 'utf-8'
54 The character-set used in the PO files.
55
56 =cut
57
58 sub new(@)
59 { my $class = shift;
60 (bless {}, $class)->init( {@_} );
61 }
62
63 sub init($)
64 { my ($self, $args) = @_;
65 my $lexi = $args->{lexicon}
66 or error __"PerlPPI requires explicit lexicon directory";
67
68 -d $lexi or mkdir $lexi
69 or fault __x"cannot create lexicon directory {dir}", dir => $lexi;
70
71 $self->{index} = Log::Report::Lexicon::Index->new($lexi);
72 $self->{charset} = $args->{charset} || 'utf-8';
73 $self;
74 }
75
76 =section Accessors
77
78 =method index
79 Returns the M<Log::Report::Lexicon::Index> object, which is listing
80 the files in the lexicon directory tree.
81
82 =method charset
83 Returns the character-set used inside the POT files.
84
85 =method domains
86 Returns a sorted list of all known domain names.
87 =cut
88
89 sub index() {shift->{index}}
90 sub charset() {shift->{charset}}
91 sub domains() {sort keys %{shift->{domains}}}
92
93 =section Processors
94
95 =method process FILENAME, OPTIONS
96 Update the domains mentioned in the FILENAME. All textdomains defined
97 in the file will get updated automatically, but not written before
98 all files where processed.
99
100 =option charset STRING
101 =default charset 'iso-8859-1'
102 =cut
103
104 sub process($@)
105 { my ($self, $fn, %opts) = @_;
106
107 my $charset = $opts{charset} || 'iso-8859-1';
108 info __x"processing file {fn} in {charset}", fn=> $fn, charset => $charset;
109
110 $charset eq 'iso-8859-1'
111 or error __x"PPI only supports iso-8859-1 (latin-1) on the moment";
112
113 my $doc = PPI::Document->new($fn, readonly => 1)
114 or fault __x"cannot read from file {filename}", filename => $fn;
115
116 my ($pkg, $include, $domain) = ('main', 0, undef);
117
118 NODE:
119 foreach my $node ($doc->schildren)
120 { if($node->isa('PPI::Statement::Package'))
121 { $pkg = $node->namespace;
122
123 # special hack for module Log::Report itself
124 if($pkg eq 'Log::Report')
125 { ($include, $domain) = (1, 'log-report');
126 $self->_reset($domain, $fn);
127 }
128 else { ($include, $domain) = (0, undef) }
129
130 next NODE;
131 }
132
133 if($node->isa('PPI::Statement::Include'))
134 { next NODE if $node->type ne 'use' || $node->module ne 'Log::Report';
135 $include++;
136 my $dom = ($node->schildren)[2];
137 $domain = $dom->isa('PPI::Token::Quote') ? $dom->string : undef;
138 $self->_reset($domain, $fn);
139 }
140
141 $node->find_any
142 ( sub { # look for the special translation markers
143 $_[1]->isa('PPI::Token::Word') or return 0;
144
145 my $node = $_[1];
146 my $def = $msgids{$node->content}
147 or return 0;
148
149 my @msgids = $self->_get($node, @$def)
150 or return 0;
151
152 my $line = $node->location->[0];
153 unless($domain)
154 { warning __x
155 "no textdomain for translatable at {fn} line {line}"
156 , fn => $fn, line => $line;
157 return 0;
158 }
159
160 if($def->[4]) # split
161 { $self->_store($domain, $fn, $line, $_)
162 for map {split} @msgids;
163 }
164 else
165 { $self->_store($domain, $fn, $line, @msgids);
166 }
167
168 0; # don't collect
169 }
170 );
171 }
172 }
173
174 sub _get($$$$$)
175 { my ($self, $node, $msgids, $count, $opts, $vars, $split) = @_;
176 my $list_only = ($msgids > 1) || $count || $opts || $vars;
177 my $expand = $opts || $vars;
178
179 my @msgids;
180 my $first = $node->snext_sibling;
181 $first = $first->schild(0)
182 if $first->isa('PPI::Structure::List');
183
184 $first = $first->schild(0)
185 if $first->isa('PPI::Statement::Expression');
186
187 while(defined $first && $msgids > @msgids)
188 { my $msgid;
189 my $next = $first->snext_sibling;
190 my $sep = $next && $next->isa('PPI::Token::Operator') ? $next : '';
191
192 if($first->isa('PPI::Token::Quote'))
193 { last if $sep !~ m/^ (?: | \, | \=\> | \; ) $/x;
194 $msgid = $first->string;
195 }
196 elsif($first->isa('PPI::Token::Word'))
197 { last if $sep ne '=>';
198 $msgid = $first->content;
199 }
200 else {last}
201
202 push @msgids, $msgid;
203 last if $msgids==@msgids || !$sep;
204
205 $first = $sep->snext_sibling;
206 }
207
208 @msgids;
209 }
210
211 =method showStats [DOMAINs]
212 Show a status about the DOMAIN (by default all domains). At least mode
213 verbose is required to see this.
214 =cut
215
216 sub showStats(;$)
217 { dispatcher needs => 'INFO'
218 or return;
219
220 my $trace = dispatcher needs => 'TRACE';
221
222 my $self = shift;
223 my @domains = @_ ? @_ : $self->domains;
224
225 foreach my $domain (@domains)
226 { my $pots = $self->{domains}{$domain} or next;
227 my ($msgids, $fuzzy, $inactive) = (0, 0, 0);
228
229 foreach my $pot (@$pots)
230 { my $stats = $pot->stats;
231 $msgids = $stats->{msgids};
232 trace __x
233 "{domain}: {fuzzy%3d} fuzzy, {inact%3d} inactive in {filename}"
234 , domain => $domain, fuzzy => $stats->{fuzzy}
235 , inact => $stats->{inactive}, filename => $pot->filename
236 if $trace;
237 $fuzzy += $stats->{fuzzy};
238 $inactive += $stats->{inactive};
239 }
240
241 info __xn
242 "{domain}: one file with {ids} msgids, {f} fuzzy and {i} inactive translations"
243 , "{domain}: {_count} files each {ids} msgids, {f} fuzzy and {i} inactive translations in total"
244 , scalar(@$pots), domain => $domain
245 , f => $fuzzy, ids => $msgids, i => $inactive;
246 }
247 }
248
249 =method write [DOMAIN]
250 Update the information of the files related to DOMAIN, by default all
251 processed DOMAINS. All information known about the DOMAIN is removed
252 from the cache.
253 =cut
254
255 sub write(;$)
256 { my ($self, $domain) = @_;
257 unless(defined $domain) # write all
258 { $self->write($_) for keys %{$self->{domains}};
259 return;
260 }
261
262 my $pots = delete $self->{domains}{$domain}
263 or return; # nothing found
264
265 for my $pot (@$pots)
266 { $pot->updated;
267 $pot->write;
268 }
269
270 $self;
271 }
272
273 sub DESTROY() {shift->write}
274
275 sub _reset($$)
276 { my ($self, $domain, $fn) = @_;
277
278 my $pots = $self->{domains}{$domain}
279 ||= $self->_read_pots($domain);
280
281 $_->removeReferencesTo($fn) for @$pots;
282 }
283
284 sub _read_pots($)
285 { my ($self, $domain) = @_;
286
287 my $index = $self->index;
288 my $charset = $self->charset;
289
290 my @pots = map {Log::Report::Lexicon::POT->read($_, charset=> $charset)}
291 $index->list($domain);
292
293 trace __xn "found one pot file for domain {domain}"
294 , "found {_count} pot files for domain {domain}"
295 , @pots, domain => $domain;
296
297 @pots && return \@pots;
298
299 # new textdomain
300 my $fn = $index->addFile("$domain.$charset.po");
301 info __x"starting new textdomain {domain}, template in {filename}"
302 , domain => $domain, filename => $fn;
303
304 my $pot = Log::Report::Lexicon::POT->new
305 ( textdomain => $domain
306 , filename => $fn
307 , charset => $charset
308 , version => 0.01
309 );
310
311 [ $pot ];
312 }
313
314 sub _store($$$$;$)
315 { my ($self, $domain, $fn, $linenr, $msgid, $plural) = @_;
316
317 foreach my $pot ( @{$self->{domains}{$domain}} )
318 { if(my $po = $pot->msgid($msgid))
319 { $po->addReferences( ["$fn:$linenr"]);
320 $po->plural($plural) if $plural;
321 next;
322 }
323
324 my $format = $msgid =~ m/\{/ ? 'perl-brace' : 'perl';
325 my $po = Log::Report::Lexicon::PO->new
326 ( msgid => $msgid
327 , msgid_plural => $plural
328 , fuzzy => 1
329 , format => $format
330 , references => [ "$fn:$linenr" ]
331 );
332
333 $pot->add($po);
334 }
335 }
336
337 1;
+257
-0
lib/Log/Report/Lexicon/Index.pm less more
0
1 package Log::Report::Lexicon::Index;
2
3 use warnings;
4 use strict;
5
6 use File::Find ();
7
8 use Log::Report 'log-report', syntax => 'SHORT';
9 use Log::Report::Util qw/parse_locale/;
10
11 =chapter NAME
12 Log::Report::Lexicon::Index - search through available translation files
13
14 =chapter SYNOPSIS
15 my $index = Log::Report::Lexicon::Index->new($directory);
16 my $fn = $index->find('my-domain', 'nl-NL.utf-8');
17
18 =chapter DESCRIPTION
19 This module handles the lookup of translation files for a whole
20 directory tree. It is lazy loading, which means that it will only
21 build the search tree when addressed, not when the object is
22 created.
23
24 =chapter METHODS
25
26 =section Constructors
27
28 =c_method new DIRECTORY, OPTIONS
29 =cut
30
31 sub new($;@)
32 { my $class = shift;
33 bless {dir => @_}, $class; # dir before first argument.
34 }
35
36 =section Accessors
37
38 =method directory
39 Returns the directory name.
40 =cut
41
42 sub directory() {shift->{dir}}
43
44 =section Search
45
46 =method index
47 For internal use only.
48 Force the creation of the index (if not already done). Returns a hash
49 with key-value pairs, where the key is the lower-cased version of the
50 filename, and the value the case-sensitive version of the filename.
51 =cut
52
53 sub index()
54 { my $self = shift;
55 return $self->{index} if exists $self->{index};
56
57 my $dir = $self->directory;
58 my $strip_dir = qr!\Q$dir/!;
59
60 $self->{index} = {};
61 File::Find::find
62 ( +{ wanted => sub
63 { -f or return 1;
64 (my $key = $_) =~ s/$strip_dir//;
65 $self->addFile($key, $_);
66 1;
67 }
68 , follow => 1, no_chdir => 1
69 } , $dir
70 );
71
72 $self->{index};
73 }
74
75 =method addFile BASENAME, [ABSOLUTE]
76 Add a certain file to the index. This method returns the ABSOLUTE
77 path to that file, which must be used to access it. When not explicitly
78 specified, the ABSOLUTE path will be calculated.
79 =cut
80
81 sub addFile($;$)
82 { my ($self, $base, $abs) = @_;
83 $abs ||= File::Spec->catfile($self->directory, $base);
84 $base =~ s!\\!/!g; # dos->unix
85 $self->{index}{lc $base} = $abs;
86 }
87
88 =method find TEXTDOMAIN, LOCALE
89 Lookup the best translation table, according to the rules described
90 in chapter L</DETAILS>, below.
91
92 Returned is a filename, or C<undef> if nothing is defined for the
93 LOCALE (there is no default on this level).
94
95 =error illegal locale '$locale'
96 =cut
97
98 # location to work-around platform dependent mutulations.
99 # may be extended with mo files as well.
100 sub _find($$) { $_[0]->{"$_[1].po"} }
101
102 sub find($$)
103 { my $self = shift;
104 my $domain = lc shift;
105 my $locale = lc shift;
106
107 my $index = $self->index;
108 keys %$index or return undef;
109
110 my ($lang,$terr,$cs,$modif) = parse_locale $locale
111 or error "illegal locale '{locale}', when looking for {domain}"
112 , locale => $locale, domain => $domain;
113
114 $terr = defined $terr ? '_'.$terr : '';
115 $cs = defined $cs ? '.'.$cs : '';
116 $modif = defined $modif ? '@'.$modif : '';
117
118 (my $normcs = $cs) =~ s/[^a-z\d]//g;
119 $normcs = "iso$normcs"
120 if length $normcs && $normcs !~ /\D/;
121 $normcs = '.'.$normcs
122 if length $normcs;
123
124 my $fn;
125
126 for my $f ("/lc_messages/$domain", "/$domain")
127 { $fn
128 ||= _find($index, "$lang$terr$cs$modif$f")
129 || _find($index, "$lang$terr$normcs$modif$f")
130 || _find($index, "$lang$terr$modif$f")
131 || _find($index, "$lang$modif$f")
132 || _find($index, "$lang$f");
133 }
134
135 $fn
136 || _find($index, "$domain/$lang$terr$cs$modif")
137 || _find($index, "$domain/$lang$terr$normcs$modif")
138 || _find($index, "$domain/$lang$terr$modif")
139 || _find($index, "$domain/$lang$modif")
140 || _find($index, "$domain/$lang");
141 }
142
143 =method list DOMAIN
144 Returned is a list of filenames which is used to update the list of
145 MSGIDs when source files have changed. All translation files which
146 belong to a certain DOMAIN are listed.
147
148 You probably need to filter the filenames further, for instance to reduce
149 the set to only C<.po> files, get rit of C<mo> files and readme's.
150 =cut
151
152 sub list($)
153 { my $self = shift;
154 my $domain = lc shift;
155 my $index = $self->index;
156
157 map { $index->{$_} }
158 grep m! ^\Q$domain\E/ | \b\Q$domain\E[^/]*$ !x
159 , keys %$index;
160 }
161
162 =chapter DETAILS
163
164 It's always complicated to find the lexicon files, because the perl
165 package can be installed on any weird operating system. Therefore,
166 you may need to specify the lexicon directory or alternative directories
167 explicitly. However, you may also choose to install the lexicon files
168 inbetween the perl modules.
169
170 =section merge lexicon files with perl modules
171 By default, the filename which contains the package which contains the
172 textdomain's translator configuration is taken (that can be only one)
173 and changed into a directory name. The path is then extended with C<messages>
174 to form the root of the lexicon: the top of the index. After this,
175 the locale indication, the lc-category (usually LC_MESSAGES), and
176 the C<textdomain> followed by C<.po> are added. This is exactly as
177 C<gettext(1)> does, but then using the PO text file instead of the MO
178 binary file.
179
180 =example lexicon in module tree
181 My module is named C<Some::Module> and installed in
182 some of perl's directories, say C<~perl5.8.8>. The module is defining
183 textdomain C<my-domain>. The translation is made into C<nl-NL.utf-8>
184 (locale for Dutch spoken in The Netherlands, utf-8 encoded text file).
185
186 The default location for the translation table is under
187 ~perl5.8.8/Some/Module/messages/
188
189 for instance
190 ~perl5.8.8/Some/Module/messages/nl-NL.utf-8/LC_MESSAGES/my-domain.po
191
192 There are alternatives, as described in M<Log::Report::Lexicon::Index>,
193 for instance
194 ~perl5.8.8/Some/Module/messages/my-domain/nl-NL.utf-8.po
195 ~perl5.8.8/Some/Module/messages/my-domain/nl.po
196
197 =section Locale search
198
199 The exact gettext defined format of the locale is
200 language[_territory[.codeset]][@modifier]
201 The modifier will be used in above directory search, but only if provided
202 explicitly.
203
204 The manual C<info gettext> determines the rules. During the search,
205 components of the locale get stripped, in the following order:
206 =over 4
207 =item 1. codeset
208 =item 2. normalized codeset
209 =item 3. territory
210 =item 4. modifier
211 =back
212
213 The normalized codeset (character-set name) is derived by
214 =over 4
215 =item 1. Remove all characters beside numbers and letters.
216 =item 2. Fold letters to lowercase.
217 =item 3. If the same only contains digits prepend the string "iso".
218 =back
219
220 To speed-up the search for the right table, the full directory tree
221 will be indexed only once when needed the first time. The content of
222 all defined lexicon directories will get merged into one tree.
223
224 =section Example
225
226 My module is named C<Some::Module> and installed in some of perl's
227 directories, say C<~perl5>. The module is defining textdomain
228 C<my-domain>. The translation is made into C<nl-NL.utf-8> (locale for
229 Dutch spoken in The Netherlands, utf-8 encoded text file).
230
231 The translation table is taken from the first existing of these files:
232 nl-NL.utf-8/LC_MESSAGES/my-domain.po
233 nl-NL.utf-8/LC_MESSAGES/my-domain.po
234 nl-NL.utf8/LC_MESSAGES/my-domain.po
235 nl-NL/LC_MESSAGES/my-domain.po
236 nl/LC_MESSAGES/my-domain.po
237
238 Then, attempts are made which are not compatible with gettext. The
239 advantange is that the directory structure is much simpler. The idea
240 is that each domain has its own locale installation directory, instead
241 of everything merged in one place, what gettext presumes.
242
243 In order of attempts:
244 nl-NL.utf-8/my-domain.po
245 nl-NL.utf8/my-domain.po
246 nl-NL/my-domain.po
247 nl/my-domain.po
248 my-domain/nl-NL.utf8.po
249 my-domain/nl-NL.po
250 my-domain/nl.po
251
252 Filenames may get mutulated by the platform (which we will try to hide
253 from you [please help improve this]), and are treated case-INsensitive!
254 =cut
255
256 1;
+456
-0
lib/Log/Report/Lexicon/PO.pm less more
0
1 use warnings;
2 use strict;
3
4 package Log::Report::Lexicon::PO;
5
6 use Log::Report 'log-report', syntax => 'SHORT';
7
8 # mixins
9 use Log::Report::Lexicon::POTcompact qw/_escape _unescape/;
10
11 =chapter NAME
12 Log::Report::Lexicon::PO - one translation definition
13
14 =chapter SYNOPSIS
15
16 =chapter DESCRIPTION
17 This module is administering one translation object. Sets of PO
18 objects are kept in a POT file, implemented in M<Log::Report::Lexicon::POT>.
19
20 =chapter METHODS
21
22 =section Constructors
23
24 =c_method new OPTIONS
25
26 =requires msgid STRING
27
28 =option msgid_plural STRING
29 =default msgid_plural C<undef>
30
31 =option msgstr STRING|ARRAY-OF-STRING
32 =default msgstr "" or []
33 The translations for the msgid. When msgid_plural is defined, then an
34 ARRAY must be provided.
35
36 =option comment PARAGRAPH
37 =default comment []
38 Translator added comments.
39 See M<addComment()>.
40
41 =option fuzzy BOOLEAN
42 =default fuzzy C<false>
43 The string is not yet translated, some smart guesses may have been made.
44 See M<fuzzy()>.
45
46 =option automatic PARAGRAPH
47 =default automatic ""
48 Automaticly added comments.
49 See M<addAutomatic()>.
50
51 =option references STRING|ARRAY-OF-LOCATIONS
52 =default references []
53 The STRING is a blank separated list of LOCATIONS.
54 LOCATIONs are of the form C<filename:linenumber>, for
55 instance C<lib/Foo.pm:42>
56 See M<addReferences()>
57
58 =option format ARRAY-OF-PAIRS|HASH
59 =default format C<[]>
60 See M<format()>.
61 =cut
62
63 sub new(@)
64 { my $class = shift;
65 (bless {}, $class)->init( {@_} );
66 }
67
68 sub init($)
69 { my ($self, $args) = @_;
70 defined($self->{msgid} = delete $args->{msgid})
71 or error "no msgid defined for PO";
72
73 $self->{plural} = delete $args->{msgid_plural};
74 my $str = delete $args->{msgstr};
75 $self->{msgstr}
76 = !defined $str ? []
77 : ref $str eq 'ARRAY' ? $str
78 : [$str];
79
80 $self->addComment(delete $args->{comment});
81 $self->addAutomatic(delete $args->{automatic});
82 $self->fuzzy(delete $args->{fuzzy});
83
84 $self->{refs} = {};
85 $self->addReferences(delete $args->{references})
86 if defined $args->{references};
87
88 $self;
89 }
90
91 =section Attributes
92
93 =method msgid
94 Returns the actual msgid, which cannot be C<undef>.
95 =cut
96
97 sub msgid() {shift->{msgid}}
98
99 =method plural [STRING]
100 Returns the actual msgid_plural, which can be C<undef>.
101 =cut
102
103 sub plural(;$)
104 { my $self = shift;
105 @_ ? ($self->{plural} = shift) : $self->{plural};
106 }
107
108 =method msgstr [INDEX, [STRING]]
109 With a STRING, a new translation will be set. Without STRING, a
110 lookup will take place. When no plural is defined, use INDEX 0
111 =cut
112
113 sub msgstr($;$)
114 { my $self = shift;
115 return $self->{msgstr}[shift || 0]
116 if @_ < 2;
117
118 my ($nr, $string) = @_;
119 $self->{msgstr}[$nr] = $string;
120 }
121
122 =method comment [LIST|ARRAY|STRING]
123 Returns a STRING which contains the cleaned paragraph of translator's
124 comment. If an argument is specified, it will replace the current
125 comment.
126 =cut
127
128 sub comment(@)
129 { my $self = shift;
130 @_ or return $self->{comment};
131 $self->{comment} = '';
132 $self->addComment(@_);
133 }
134
135 =method addComment LIST|ARRAY|STRING
136 Add multiple lines to the translator's comment block. Returns an
137 empty string if there are no comments.
138 =cut
139
140 sub addComment(@)
141 { my $self = shift;
142 my $comment = $self->{comment};
143 foreach my $line (ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_)
144 { defined $line or next;
145 $line =~ s/[\r\n]+/\n/; # cleanup line-endings
146 $comment .= $line;
147 }
148
149 # be sure there is a \n at the end
150 $comment =~ s/\n?\z/\n/ if defined $comment;
151 $self->{comment} = $comment;
152 }
153
154 =method automatic [LIST|ARRAY|STRING]
155 Returns a STRING which contains the cleaned paragraph of automatically
156 added comments. If an argument is specified, it will replace the current
157 comment.
158 =cut
159
160 sub automatic(@)
161 { my $self = shift;
162 @_ or return $self->{automatic};
163 $self->{automatic} = '';
164 $self->addAutomatic(@_);
165 }
166
167 =method addAutomatic LIST|ARRAY|STRING
168 Add multiple lines to the translator's comment block. Returns an
169 empty string if there are no comments.
170 =cut
171
172 sub addAutomatic(@)
173 { my $self = shift;
174 my $auto = $self->{automatic};
175 foreach my $line (ref $_[0] eq 'ARRAY' ? @{$_[0]} : @_)
176 { defined $line or next;
177 $line =~ s/[\r\n]+/\n/; # cleanup line-endings
178 $auto .= $line;
179 }
180
181 $auto =~ s/\n?\z/\n/ if defined $auto; # be sure there is a \n at the end
182 $self->{automatic} = $auto;
183 }
184
185 =method references [STRING|LIST|ARRAY]
186 Returns an unsorted list of LOCATIONS. When options are specified,
187 then those will be used to replace all currently defined references.
188 Returns the unsorted LIST of references.
189 =cut
190
191 sub references(@)
192 { my $self = shift;
193 if(@_)
194 { $self->{refs} = {};
195 $self->addReferences(@_);
196 }
197
198 keys %{$self->{refs}};
199 }
200
201 =method addReferences STRING|LIST|ARRAY
202 The STRING is a blank separated list of LOCATIONS. The LIST and
203 ARRAY contain separate LOCATIONs. A LOCATION is of the form
204 C<filename:linenumber>. Returns the internal HASH with references.
205 =cut
206
207 sub addReferences(@)
208 { my $self = shift;
209 my $refs = $self->{refs} ||= {};
210 @_ or return $refs;
211
212 $refs->{$_}++
213 for @_ > 1 ? @_ # list
214 : ref $_[0] eq 'ARRAY' ? @{$_[0]} # array
215 : split " ",$_[0]; # scalar
216 $refs;
217 }
218
219 =method removeReferencesTo FILENAME
220 Remove all the references to the indicate FILENAME from the list. Returns
221 the number of refs left.
222 =cut
223
224 sub removeReferencesTo($)
225 { my $refs = $_[0]->{refs};
226 my $match = qr/^\Q$_[1]\E\:\d+$/;
227 $_ =~ $match && delete $refs->{$_}
228 for keys %$refs;
229
230 scalar keys %$refs;
231 }
232
233 =method isActive
234 Returns whether the translation has any references, or is the header.
235 =cut
236
237 sub isActive() { $_[0]->{msgid} eq '' || keys %{$_[0]->{refs}} }
238
239 =method fuzzy [BOOLEAN]
240 Returns whether the translation needs human inspection.
241 =cut
242
243 sub fuzzy(;$) {my $self = shift; @_ ? $self->{fuzzy} = shift : $self->{fuzzy}}
244
245 =method format LANGUAGE|PAIRS|ARRAY-OF-PAIRS|HASH
246 When one LANGUAGE is specified, it looks whether a C<LANGUAGE-format> or
247 C<no-LANGUAGE-format> is present in the line of FLAGS. This will return
248 C<1> (true) in the first case, C<0> (false) in the second case. It will
249 return C<undef> (also false) in case that both are not present.
250
251 You can also specify PAIRS: the key is a language name, and the
252 value is either C<0>, C<1>, or C<undef>.
253
254 =examples use of format()
255 if($po->format('c')) ...
256 unless($po->format('perl-brace')) ...
257 if(defined $po->format('java')) ...
258
259 $po->format(java => 1); # results in 'java-format'
260 $po->format(java => 0); # results in 'no-java-format'
261 $po->format(java => undef); # results in ''
262 =cut
263
264 sub format(@)
265 { my $format = shift->{format};
266 return $format->{ (shift) }
267 if @_==1 && !ref $_[0]; # language
268
269 my @pairs = @_ > 1 ? @_ : ref $_[0] eq 'ARRAY' ? @{$_[0]} : %{$_[0]};
270 while(@pairs)
271 { my($k, $v) = (shift @pairs, shift @pairs);
272 $format->{$k} = $v;
273 }
274 $format;
275 }
276
277 =method addFlags STRING
278 Parse a "flags" line.
279 =cut
280
281 sub addFlags($)
282 { my $self = shift;
283 local $_ = shift;
284 my $where = shift;
285
286 s/^\s+//;
287 s/\s*$//;
288 foreach my $flag (split /\s*\,\s*/)
289 { if($flag eq 'fuzzy') { $self->fuzzy(1) }
290 elsif($flag =~ m/^no-(.*)-format$/) { $self->format($1, 0) }
291 elsif($flag =~ m/^(.*)-format$/) { $self->format($1, 1) }
292 else
293 { warning __x"unknown flag {flag} ignored", flag => $flag;
294 }
295 }
296 $_;
297 }
298 =section Parsing
299
300 =c_method fromText STRING, [WHERE]
301 Parse the STRING into a new PO object. The WHERE string should explain
302 the location of the STRING, to be used in error messages.
303 =cut
304
305 sub fromText($$)
306 { my $class = shift;
307 my @lines = split /[\r\n]+/, shift;
308 my $where = shift || ' unkown location';
309
310 my $self = bless {}, $class;
311
312 # translations which are not used anymore are escaped with #~
313 # however, we just say: no references found.
314 s/^\#\~\s+// for @lines;
315
316 my $last;
317 foreach (@lines)
318 { chomp;
319 if( s/^\#(.)\s?// )
320 { if($1 =~ /\s/) { $self->addComment($_) }
321 elsif($1 eq '.' ) { $self->addAutomatic($_) }
322 elsif($1 eq ':' ) { $self->addReferences($_) }
323 elsif($1 eq ',' ) { $self->addFlags($_) }
324 else
325 { warning __x"unknown comment type '{cmd}' at {where}"
326 , cmd => "#$1", where => $where;
327 }
328 undef $last;
329 }
330 elsif( s/^\s*(\w+)\s+// )
331 { my $cmd = $1;
332 my $string = _unescape($_,$where);
333
334 if($cmd eq 'msgid')
335 { $self->{msgid} = $string;
336 $last = \($self->{msgid});
337 }
338 elsif($cmd eq 'msgid_plural')
339 { $self->{plural} = $string;
340 $last = \($self->{plural});
341 }
342 elsif($cmd eq 'msgstr')
343 { $self->{msgstr} = [$string];
344 $last = \($self->{msgstr}[0]);
345 }
346 else
347 { warning __x"do not understand command '{cmd}' at {where}"
348 , cmd => $cmd, where => $where;
349 undef $last;
350 }
351 }
352 elsif( s/^\s*msgstr\[(\d+)\]\s*// )
353 { my $nr = $1;
354 $self->{msgstr}[$nr] = _unescape($_,$where);
355 }
356 elsif( m/^\s*\"/ )
357 { if(defined $last) { $$last .= _unescape($_,$where) }
358 else
359 { warning __x"quoted line is not a continuation at {where}"
360 , where => $where;
361 }
362 }
363 else
364 { warning __x"do not understand line at {where}:\n {line}"
365 , where => $where, line => $_;
366 }
367 }
368
369 warning __x"no msgid in block {where}", where => $where
370 unless defined $self->{msgid};
371
372 $self;
373 }
374
375 =method toString OPTIONS
376 Format the object into a multi-lined string.
377 =option nr_plurals INTEGER
378 =default nr_plurals C<undef>
379 If the number of plurals is specified, then the plural translation
380 list can be checked for the correct lenght. Otherwise, no smart
381 behavior is attempted.
382 =cut
383
384 sub toString(@)
385 { my ($self, %args) = @_;
386 my $nplurals = $args{nr_plurals};
387 my @text;
388
389 my $comment = $self->comment;
390 if(defined $comment && length $comment)
391 { $comment =~ s/^/# /gm;
392 push @text, $comment;
393 }
394
395 my $auto = $self->automatic;
396 if(defined $auto && length $auto)
397 { $auto =~ s/^/#. /gm;
398 push @text, $auto;
399 }
400
401 my @refs = sort $self->references;
402 my $msgid = $self->{msgid} || '';
403 my $active = $msgid eq '' || @refs ? '' : '#~ ';
404
405 while(@refs)
406 { my $line = '#:';
407 $line .= ' '.shift @refs
408 while @refs && length($line) + length($refs[0]) < 80;
409 push @text, "$line\n";
410 }
411
412 my @flags = $self->{fuzzy} ? 'fuzzy' : ();
413
414 push @flags, ($self->{format}{$_} ? '' : 'no-') . $_ . '-format'
415 for sort keys %{$self->{format}};
416
417 push @text, "#, ". join(", ", @flags) . "\n"
418 if @flags;
419
420 push @text, "${active}msgid "._escape($msgid, "\n$active")."\n";
421
422 my @msgstr = @{$self->{msgstr} || []};
423 my $plural = $self->{plural};
424 if(defined $plural)
425 { push @text, "${active}msgid_plural "
426 . _escape($plural, "\n$active")
427 . "\n";
428
429 push @msgstr, ''
430 while defined $nplurals && @msgstr < $nplurals;
431
432 if(defined $nplurals && @msgstr > $nplurals)
433 { warning __x"too many plurals for '{msgid}'", msgid => $msgid;
434 $#msgstr = $nplurals -1;
435 }
436
437 $nplurals ||= 2;
438 for(my $nr = 0; $nr < $nplurals; $nr++)
439 { push @text, "${active}msgstr[$nr] "
440 . _escape($msgstr[$nr], "\n$active") . "\n";
441 }
442 }
443 else
444 { warning __x"no plurals for '{msgid}'", msgid => $msgid
445 if @msgstr > 1;
446
447 push @text, "${active}msgstr "
448 . _escape($msgstr[0], "\n$active")
449 . "\n";
450 }
451
452 join '', @text;
453 }
454
455 1;
+414
-0
lib/Log/Report/Lexicon/POT.pm less more
0
1 use warnings;
2 use strict;
3
4 package Log::Report::Lexicon::POT;
5
6 use Log::Report 'log-report', syntax => 'SHORT';
7
8 use Log::Report::Lexicon::PO;
9 use Log::Report::Lexicon::POTcompact qw/_plural_algorithm _nr_plurals/;
10
11 use POSIX qw/strftime/;
12 use IO::Handle;
13 use IO::File;
14 use List::Util qw/sum/;
15
16 =chapter NAME
17 Log::Report::Lexicon::POT - manage PO files
18
19 =chapter SYNOPSIS
20 # this is usually not for end-users, See ::Extract::PerlPPI
21 # using a PO table
22
23 my $pot = Log::Report::Lexicon::POT
24 ->read('po/nl.po', charset => 'utf-8')
25 or die;
26
27 my $po = $pot->msgid('');
28 print $pot->nrPlurals;
29 print $pot->msgstr('msgid', 3);
30 $pot->write;
31
32 # creating a PO table
33
34 my $po = Log::Report::Lexicon::PO->new(...);
35 $pot->add($po);
36
37 $pot->write('po/nl.po')
38 or die;
39
40 =chapter DESCRIPTION
41 This module is reading, extending, and writing POT files. POT files
42 are used to store translations in humanly readible format for most of
43 existing translation frameworks, like GNU gettext and Perl's Maketext.
44 If you only wish to access the translation, then you may use the much
45 more efficient M<Log::Report::Lexicon::POTcompact>.
46
47 The code is loosely based on M<Locale::PO>, by Alan Schwartz. The coding
48 style is a bit off the rest of C<Log::Report>, and there was a need to
49 sincere simplification. Each PO object will be represented by a
50 M<Log::Report::Lexicon::PO>.
51
52 =chapter METHODS
53
54 =section Constructors
55
56 =c_method new OPTIONS
57 Create a new POT file. The initial header is generated for you, but
58 it can be changed using the M<header()> method.
59
60 =requires charset STRING
61 The character-set which is used for the output.
62
63 =requires textdomain STRING
64 The package name, used in the directory structure to store the
65 PO files.
66
67 =option version STRING
68 =default version C<undef>
69
70 =option nr_plurals INTEGER
71 =default nr_plurals 2
72 The number of translations each of the translation with plural form
73 need to have.
74
75 =option plural_alg EXPRESSION
76 =default plural_alg C<n!=1>
77 The algorithm to be used to calculate which translated msgstr to use.
78
79 =option index HASH
80 =default index {}
81 A set of translations (M<Log::Report::Lexicon::PO> objects),
82 with msgid as key.
83
84 =option date STRING
85 =default date now
86 Overrule the date which is included in the gerenated header.
87
88 =option filename STRING
89 =default filename C<undef>
90 Specify an output filename. The name can also be specified when
91 M<write()> is called.
92
93 =error charset parameter is required
94 =error textdomain parameter is required
95 =cut
96
97 sub new(@)
98 { my $class = shift;
99 (bless {}, $class)->init( {@_} );
100 }
101
102 sub init($)
103 { my ($self, $args) = @_;
104
105 $self->{filename} = $args->{filename};
106 $self->{charset} = $args->{charset}
107 or error __x"charset parameter is required for {fn}"
108 , fn => ($args->{filename} || __"unnamed file");
109
110 my $version = $args->{version};
111 my $domain = $args->{textdomain}
112 or error __"textdomain parameter is required";
113
114 my $nplurals = $self->{nplurals} = $args->{nr_plurals} || 2;
115 my $algo = $args->{plural_alg} || 'n!=1';
116 $self->{alg} = _plural_algorithm $algo;
117
118 $self->{index} = $args->{index} || {};
119 $self->_createHeader
120 ( project => $domain . (defined $version ? " $version" : '')
121 , forms => "nplurals=$nplurals; plural=($algo);"
122 , charset => $args->{charset}
123 , date => $args->{date}
124 );
125
126 $self;
127 }
128
129 =c_method read FILENAME, OPTIONS
130 Read the POT information from FILENAME.
131
132 =requires charset STRING
133 The character-set which is used for the file. You must specify
134 this explicitly, while it cannot be trustfully detected automatically.
135 =cut
136
137 sub read($@)
138 { my ($class, $fn, %args) = @_;
139
140 my $self = bless {}, $class;
141
142 my $charset = $self->{charset} = $args{charset}
143 or error __x"charset parameter is required for {fn}", fn => $fn;
144
145 open my $fh, "<:encoding($charset)", $fn
146 or fault __x"cannot read in {cs} from file {fn}"
147 , cs => $charset, fn => $fn;
148
149 local $/ = "\n\n";
150 while(1)
151 { my $location = "$fn line ".$fh->input_line_number;
152 my $block = <$fh>;
153 defined $block or last;
154
155 $block =~ s/\s+\z//s;
156 length $block or last;
157
158 my $po = Log::Report::Lexicon::PO->fromText($block, $location);
159 $self->add($po) if $po;
160 }
161
162 close $fh
163 or failure __x"failed reading from file {fn}", fn => $fn;
164
165 $self->{filename} = $fn;
166 $self;
167 }
168
169 =method write [FILENAME|FILEHANDLE], OPTIONS
170 When you pass an open FILEHANDLE, you are yourself responsible that
171 the correct character-encoding (binmode) is set. When the write
172 followed a M<read()> or the filename was explicitly set with M<filename()>,
173 then you may omit the first parameter.
174
175 =error no filename or file-handle specified for PO
176 When a PO file is written, then a filename or file-handle must be
177 specified explicitly, or set beforehand using the M<filename()>
178 method, or known because the write follows a M<read()> of the file.
179 =cut
180
181 sub write($@)
182 { my $self = shift;
183 my $file = @_%2 ? shift : $self->filename;
184 my %args = @_;
185
186 defined $file
187 or error __"no filename or file-handle specified for PO";
188
189 my @opt = (nplurals => $self->nrPlurals);
190
191 my $fh;
192 if(ref $file) { $fh = $file }
193 else
194 { my $layers = '>:encoding('.$self->charset.')';
195 open $fh, $layers, $file
196 or fault __x"cannot write to file {fn} in {layers}"
197 , fn => $file, layers => $layers;
198 }
199
200 $fh->print($self->msgid("")->toString(@opt));
201 my $index = $self->index;
202 foreach my $msgid (sort keys %$index)
203 { next if $msgid eq '';
204 $fh->print("\n", $index->{$msgid}->toString(@opt));
205 }
206
207 $fh->close
208 or failure __x"write errors for file {fn}", fn => $file;
209
210 $self;
211 }
212
213 =section Attributes
214
215 =method charset
216 The character-set to be used for reading and writing. You do not need
217 to be aware of Perl's internal encoding for the characters.
218
219 =method index
220 Returns a HASH of all defined PO objects, organized by msgid. Please try
221 to avoid using this: use M<msgid()> for lookup and M<add()> for adding
222 translations.
223
224 =method filename
225 Returns the FILENAME, as derived from M<read()> or specified during
226 initiation with M<new(filename)>.
227 =cut
228
229 sub charset() {shift->{charset}}
230 sub index() {shift->{index}}
231 sub filename() {shift->{filename}}
232
233 =section Managing PO's
234
235 =method msgid STRING
236 Lookup the M<Log::Report::Lexicon::PO> with the STRING. If you
237 want to add a new translation, use M<add()>. Returns C<undef>
238 when not defined.
239 =cut
240
241 sub msgid($) { $_[0]->{index}{$_[1]} }
242
243 =method msgstr MSGID, [COUNT]
244 Returns the translated string for MSGID. When not specified, COUNT is 1.
245 =cut
246
247 sub msgstr($;$)
248 { my $self = shift;
249 my $po = $self->msgid(shift)
250 or return undef;
251
252 $po->msgstr(defined $_[0] ? $self->pluralIndex($_[0]) : 0);
253 }
254
255 =method add PO
256 Add the information from a PO into this POT. If the msgid of the PO
257 is already known, that is an error.
258 =cut
259
260 sub add($)
261 { my ($self, $po) = @_;
262 my $msgid = $po->msgid;
263
264 $self->{index}{$msgid}
265 and error __x"translation already exists for '{msgid}'", msgid => $msgid;
266
267 $self->{index}{$msgid} = $po;
268 }
269
270 =method translations [ACTIVE]
271 Returns a list with all defined M<Log::Report::Lexicon::PO> objects. When
272 the string C<ACTIVE> is given as parameter, only objects which have
273 references are returned.
274
275 =error only acceptable parameter is 'ACTIVE'
276 =cut
277
278 sub translations(;$)
279 { my $self = shift;
280 @_ or return values %{$self->{index}};
281
282 error __x"the only acceptable parameter is 'ACTIVE', not '{p}'", p => $_[0]
283 if $_[0] ne 'ACTIVE';
284
285 grep { $_->isActive } $self->translations;
286 }
287
288 =method pluralIndex COUNT
289 Returns the msgstr index used to translate a value of COUNT.
290 =cut
291
292 sub pluralIndex($)
293 { my ($self, $count) = @_;
294 my $alg = $self->{alg}
295 ||= _plural_algorithm($self->header('Plural-Forms'));
296 $alg->($count);
297 }
298
299 =method nrPlurals
300 Returns the number of plurals, when not known then '2'.
301 =cut
302
303 sub nrPlurals()
304 { my $self = shift;
305 $self->{nplurals} ||= _nr_plurals($self->header('Plural-Forms'));
306 }
307
308 =method header FIELD, [CONTENT]
309 The translation of a blank MSGID is used to store a MIME header, which
310 contains headeruration information. When only a FIELD is specified, that
311 content is looked-up (case-insensitive). When a CONTENT is specified,
312 the knowledge will be stored. In latter case, the headeruration structure
313 may get created. When the CONTENT is set to C<undef>, the field will
314 be removed.
315 =cut
316
317 sub _now() { strftime "%Y-%m-%d %H:%M%z", localtime }
318
319 sub header($;$)
320 { my ($self, $field) = (shift, shift);
321 my $header = $self->msgid('')
322 or error __x"no header defined in POT for file {fn}"
323 , fn => $self->filename;
324
325 if(!@_)
326 { my $text = $header->msgstr(0) || '';
327 return $text =~ m/^\Q$field\E\:\s*([^\n]*?)\;?\s*$/im ? $1 : undef;
328 }
329
330 my $content = shift;
331 my $text = $header->msgstr(0);
332
333 for($text)
334 { if(defined $content)
335 { s/^\Q$field\E\:([^\n]*)/$field: $content/im # change
336 || s/\z/$field: $content\n/; # new
337 }
338 else
339 { s/^\Q$field\E\:[^\n]*\n?//im; # remove
340 }
341 }
342
343 $header->msgstr(0, $text);
344 $content;
345 }
346
347 =method updated [DATE]
348 Replace the "PO-Revision-Date" with the specified DATE, or the current
349 moment.
350 =cut
351
352 sub updated(;$)
353 { my $self = shift;
354 my $date = shift || _now;
355 $self->header('PO-Revision-Date', $date);
356 $date;
357 }
358
359 ### internal
360 sub _createHeader(%)
361 { my ($self, %args) = @_;
362 my $date = $args{date} || _now;
363
364 my $header = Log::Report::Lexicon::PO->new
365 ( msgid => '', msgstr => <<__CONFIG);
366 Project-Id-Version: $args{project}
367 Report-Msgid-Bugs-To:
368 POT-Creation-Date: $date
369 PO-Revision-Date: $date
370 Last-Translator:
371 Language-Team:
372 MIME-Version: 1.0
373 Content-Type: text/plain; charset=$args{charset}
374 Content-Transfer-Encoding: 8bit
375 Plural-Forms: $args{forms}
376 __CONFIG
377
378 my $version = $Log::Report::VERSION || '0.0';
379 $header->addAutomatic("Header generated with ".__PACKAGE__." $version\n");
380
381 $self->index->{''} = $header
382 if $header;
383
384 $header;
385 }
386
387 =method removeReferencesTo FILENAME
388 Remove all the references to the indicate FILENAME from all defined
389 translations. Returns the number of refs left.
390 =cut
391
392 sub removeReferencesTo($)
393 { my ($self, $filename) = @_;
394 sum map { $_->removeReferencesTo($filename) } $self->translations;
395 }
396
397 =method stats
398 Returns a HASH with some statistics about this POT table.
399 =cut
400
401 sub stats()
402 { my $self = shift;
403 my %stats = (msgids => 0, fuzzy => 0, inactive => 0);
404 foreach my $po ($self->translations)
405 { next if $po->msgid eq '';
406 $stats{msgids}++;
407 $po->fuzzy and $stats{fuzzy}++;
408 $po->isActive or $stats{inactive}++;
409 }
410 \%stats;
411 }
412
413 1;
+210
-0
lib/Log/Report/Lexicon/POTcompact.pm less more
0
1 use warnings;
2 use strict;
3
4 package Log::Report::Lexicon::POTcompact;
5 use base 'Exporter';
6
7 # permit "mixins", not for end-users
8 our @EXPORT_OK = qw/_plural_algorithm _nr_plurals _escape _unescape/;
9
10 use IO::Handle;
11 use IO::File;
12 use List::Util qw/sum/;
13
14 use Log::Report 'log-report', syntax => 'SHORT';
15 use Log::Report::Util qw/escape_chars unescape_chars/;
16
17 sub _plural_algorithm($);
18 sub _nr_plurals($);
19 sub _unescape($$);
20
21 =chapter NAME
22 Log::Report::Lexicon::POTcompact - use translations from a POT file
23
24 =chapter SYNOPSIS
25 # using a PO table efficiently
26 my $pot = Log::Report::Lexicon::POTcompact
27 ->read('po/nl.po', charset => 'utf-8')
28 or die;
29
30 my $header = $pot->msgid('');
31 print $pot->msgstr('msgid', 3);
32
33 =chapter DESCRIPTION
34 This module is translating, based on PO files. PO files are used to store
35 translations in humanly readible format for most of existing translation
36 frameworks, like GNU gettext and Perl's Maketext.
37
38 Internally, this module tries to be as efficient as possible: high
39 speed and low memory foot-print. You will not be able to sub-class
40 this class cleanly.
41
42 If you like to change the content of PO files, then use
43 M<Log::Report::Lexicon::POT>.
44
45 =chapter METHODS
46
47 =section Constructors
48
49 =c_method read FILENAME, OPTIONS
50 Read the POT table information from FILENAME, as compact as possible.
51 Comments, plural-form, and such are lost on purpose: they are not
52 needed for translations.
53
54 =requires charset STRING
55 The character-set which is used for the file. You must specify
56 this explicitly, while it cannot be trustfully detected automatically.
57 =cut
58
59 sub read($@)
60 { my ($class, $fn, %args) = @_;
61
62 my $self = bless {}, $class;
63
64 my $charset = $args{charset}
65 or error __x"charset parameter required for {fn}", fn => $fn;
66
67 open my $fh, "<:encoding($charset)", $fn
68 or fault __x"cannot read in {cs} from file {fn}"
69 , cs => $charset, fn => $fn;
70
71 # Speed!
72 my ($last, $msgid, @msgstr);
73 LINE:
74 while(my $line = $fh->getline)
75 { next if substr($line, 0, 1) eq '#';
76
77 if($line =~ m/^\s*$/) # blank line starts new
78 { if(@msgstr)
79 { $self->{index}{$msgid} = @msgstr > 1 ? [@msgstr] : $msgstr[0];
80 ($msgid, @msgstr) = ();
81 }
82 next LINE;
83 }
84
85 if($line =~ s/^msgid\s+//)
86 { $msgid = _unescape $line, $fn;
87 $last = \$msgid;
88 }
89 elsif($line =~ s/^msgstr\[(\d+)\]\s*//)
90 { $last = \($msgstr[$1] = _unescape $line, $fn);
91 }
92 elsif($line =~ s/^msgstr\s+//)
93 { $msgstr[0] = _unescape $line, $fn;
94 $last = \$msgstr[0];
95 }
96 elsif($last && $line =~ m/^\s*\"/)
97 { $$last .= _unescape $line, $fn;
98 }
99 }
100
101 $self->{index}{$msgid} = (@msgstr > 1 ? \@msgstr : $msgstr[0])
102 if @msgstr; # don't forget the last
103
104 close $fh
105 or failure __x"failed reading from file {fn}", fn => $fn;
106
107 $self->{filename} = $fn;
108
109 my $forms = $self->header('Plural-Forms');
110 $self->{algo} = _plural_algorithm $forms;
111 $self->{nrplurals} = _nr_plurals $forms;
112 $self;
113 }
114
115 =section Attributes
116
117 =method index
118 Returns a HASH of all defined PO objects, organized by msgid. Please try
119 to avoid using this: use M<msgid()> for lookup.
120
121 =method filename
122 Returns the name of the source file for this data.
123
124 =method nrPlurals
125 =cut
126
127 sub index() {shift->{index}}
128 sub filename() {shift->{filename}}
129 sub nrPlurals() {shift->{nrplurals}}
130 sub algorithm() {shift->{algo}}
131
132 =section Managing PO's
133
134 =method msgid STRING
135 Lookup the translations with the STRING. Returns a SCALAR, when only
136 one translation is known, and an ARRAY wheren there are multiple.
137 Returns C<undef> when the translation is not defined.
138 =cut
139
140 sub msgid($) { $_[0]->{index}{$_[1]} }
141
142 =method msgstr MSGID, [COUNT]
143 Returns the translated string for MSGID. When not specified, COUNT is 1
144 (the single form).
145 =cut
146
147 # speed!!!
148 sub msgstr($;$)
149 { my $po = $_[0]->{index}{$_[1]}
150 or return undef;
151
152 ref $po # no plurals defined
153 or return $po;
154
155 $po->[$_[0]->{algo}->(defined $_[2] ? $_[2] : 1)]
156 || $po->[$_[0]->{algo}->(1)];
157 }
158
159 =method header FIELD
160 The translation of a blank MSGID is used to store a MIME header, which
161 contains headeruration information. When only a FIELD is specified, that
162 content is looked-up (case-insensitive).
163
164 =cut
165
166 sub header($)
167 { my ($self, $field) = @_;
168 my $header = $self->msgid('') or return;
169 $header =~ m/^\Q$field\E\:\s*([^\n]*?)\;?\s*$/im ? $1 : undef;
170 }
171
172 #
173 ### internal helper routines, shared with ::PO.pm and ::POT.pm
174 #
175
176 # extract algoritm from forms string
177 sub _plural_algorithm($)
178 { my $forms = shift || '';
179 my $alg = $forms =~ m/plural\=([n%!=><\s\d|&?:()]+)/ ? $1 : "n!=1";
180 $alg =~ s/\bn\b/(\$_[0])/g;
181 my $code = eval "sub(\$) {$alg}";
182 $@ and error __x"invalid plural-form algorithm '{alg}'", alg => $alg;
183 $code;
184 }
185
186 # extract number of plural versions in the language from forms string
187 sub _nr_plurals($)
188 { my $forms = shift || '';
189 $forms =~ m/\bnplurals\=(\d+)/ ? $1 : 2;
190 }
191
192 sub _unescape($$)
193 { unless( $_[0] =~ m/^\s*\"(.*)\"\s*$/ )
194 { warning __x"string '{text}' not between quotes at {location}"
195 , text => $_[0], location => $_[1];
196 return $_[0];
197 }
198 unescape_chars $1;
199 }
200
201 sub _escape($$)
202 { my @escaped = map { '"' . escape_chars($_) . '"' }
203 defined $_[0] && length $_[0] ? split(/(?<=\n)/, $_[0]) : '';
204
205 unshift @escaped, '""' if @escaped > 1;
206 join $_[1], @escaped;
207 }
208
209 1;
+376
-0
lib/Log/Report/Message.pm less more
0 use warnings;
1 use strict;
2
3 package Log::Report::Message;
4
5 use Log::Report 'log-report';
6 use POSIX qw/locale_h/;
7
8 =chapter NAME
9 Log::Report::Message - a piece of text to be translated
10
11 =chapter SYNOPSIS
12 Used internally by Log::Report
13
14 =chapter DESCRIPTION
15 Any used of a translation function, like M<Log::Report::__()> or
16 M<Log::Report::__x()> will result in this object. It will capture
17 some environmental information, and delay the translation until it
18 is needed.
19
20 Creating an object first, and translating it later, is slower than
21 translating it immediately. However, on the location where the message
22 is produced, we do not yet know to what language to translate: that
23 depends on the front-end, the log dispatcher.
24
25 See L</DETAILS> section below, for an in-depth description.
26
27 =chapter OVERLOADING
28
29 =overload stringification
30 When the object is used in string context, it will get translated.
31 Implemented as M<toString()>.
32
33 =overload as function
34 When the object is used to call as function, a new object is
35 created with the data from the original one but updated with the
36 new parameters. Implemented in C<clone()>.
37
38 =overload concatenation
39 An (accidental) use of concatenation (a dot where a comma should be
40 used) would immediately stringify the object. This is avoided by
41 overloading that operation.
42 =cut
43
44 use overload
45 '""' => 'toString'
46 , '&{}' => sub { my $obj = shift; sub{$obj->clone(@_)} }
47 , '.' => 'concat';
48
49 =chapter METHODS
50
51 =section Constructors
52 =c_method new OPTIONS, VARIABLES
53
54 =option _expand BOOLEAN
55 =default _expand C<false>
56 Indicates whether variables are filled-in.
57
58 =option _domain STRING
59 =default _domain from C<use>
60 The textdomain in which this msgid is defined.
61
62 =option _count INTEGER
63 =default _count C<undef>
64 When defined, then C<_plural> need to be defined as well.
65
66 =option _plural MSGID
67 =default _plural C<undef>
68 Can be specified when a C<_count> is specified. This plural form of
69 the message is used to simplify translation, and as fallback when no
70 translations are possible: therefore, this can best resemble an English
71 message.
72
73 =option _msgid MSGID
74 =default _msgid C<undef>
75 The message label, which refers to some translation information. Usually
76 a string which is close the English version of the error message. This
77 will also be used if there is no translation possible
78
79 =option _category INTEGER
80 =default _category C<undef>
81
82 =option _prepend STRING
83 =default _prepend C<undef>
84
85 =option _append STRING
86 =default _append C<undef>
87 =cut
88
89 sub new($@)
90 { my ($class, %args) = @_;
91 bless \%args, $class;
92 }
93
94 =method clone OPTIONS, VARIABLES
95 Returns a new object which copies info from original, and updates it
96 with the specified OPTIONS and VARIABLES. The advantage is that the
97 cached translations are shared between the objects.
98
99 =examples use of clone()
100 my $s = __x "found {nr} files", nr => 5;
101 my $t = $s->clone(nr => 3);
102 my $t = $s->(nr => 3); # equivalent
103 print $s; # found 5 files
104 print $t; # found 3 files
105 =cut
106
107 sub clone(@)
108 { my $self = shift;
109 (ref $self)->new(%$self, @_);
110 }
111
112 =section Accessors
113
114 =method prepend
115 Returns the string which is prepended to this one. Usually C<undef>.
116
117 =method msgid
118 Returns the msgid which will later be translated.
119
120 =method append
121 Returns the string or M<Log::Report::Message> object which is appended
122 after this one. Usually C<undef>.
123 =cut
124
125 sub prepend() {shift->{_prepend}}
126 sub msgid() {shift->{_msgid}}
127 sub append() {shift->{_append}}
128
129 =method toString [LOCALE]
130 Translate a message. If not specified, the default locale is used.
131 =cut
132
133 sub toString(;$)
134 { my ($self, $locale) = @_;
135 my $count = $self->{_count} || 0;
136
137 $self->{_msgid} # no translation, constant string
138 or return $self->{_prepend};
139
140 # create a translation
141 my $text = Log::Report->translator($self->{_domain})->translate($self);
142 defined $text or return ();
143
144 my $loc = defined $locale ? setlocale(LC_ALL, $locale) : undef;
145
146 if($self->{_expand})
147 { my $re = join '|', map { quotemeta $_ } keys %$self;
148 $text =~ s/\{($re)(\%[^}]*)?\}/$self->_expand($1,$2)/ge;
149 }
150
151 $text = "$self->{_prepend}$text"
152 if defined $self->{_prepend};
153
154 $text .= "$self->{_append}"
155 if defined $self->{_append};
156
157 setlocale(LC_ALL, $loc) if $loc;
158
159 $text;
160 }
161
162 sub _expand($$)
163 { my ($self, $key, $format) = @_;
164 my $value = $self->{$key};
165
166 defined $value
167 or return "(undef)";
168
169 $value = $value->($self)
170 while ref $value eq 'CODE';
171
172 use locale;
173 if(ref $value eq 'ARRAY')
174 { return $format
175 ? join($", map {sprintf $format, $_} @$value)
176 : join($", @$value);
177 }
178
179 $format
180 ? sprintf($format, $value)
181 : "$value"; # enforce stringification on objects
182 }
183
184 =method untranslated
185 Return the concatenation of the prepend, msgid, and append strings. Variable
186 expansions within the msgid is not performed.
187 =cut
188
189 sub untranslated()
190 { my $self = shift;
191 (defined $self->{_prepend} ? $self->{_prepend} : '')
192 . (defined $self->{_msgid} ? $self->{_msgid} : '')
193 . (defined $self->{_append} ? $self->{_append} : '');
194 }
195
196 =method concat STRING|OBJECT, [REVERSED]
197 This method implements the overloading of concatenation, which is needed
198 to delay translations even longer. When REVERSED is true, the STRING
199 or OBJECT (other C<Log::Report::Message>) needs to prepended, otherwise
200 appended.
201
202 =examples of concatenation
203 print __"Hello" . ' ' . __"World!";
204 print __("Hello")->concat(' ')->concat(__"World!")->concat("\n");
205
206 =cut
207
208 sub concat($;$)
209 { my ($self, $what, $reversed) = @_;
210 if($reversed)
211 { $self->{_prepend}
212 = defined $self->{_prepend} ? $what . $self->{_prepend} : $what;
213 }
214 else
215 { $self->{_append}
216 = defined $self->{_append} ? $self->{_append} . $what : $what;
217 }
218 $self;
219 }
220
221 =chapter DETAILS
222
223 =section OPTIONS and VARIABLES
224 The M<Log::Report> functions which define translation request can all
225 have OPTIONS. Some can have VARIABLES to be interpolated in the string as
226 well. To distinguish between the OPTIONS and VARIABLES (both a list
227 of key-value pairs), the keys of the OPTIONS start with an underscore C<_>.
228 As result of this, please avoid the use of keys which start with an
229 underscore in variable names. On the other hand, you are allowed to
230 interpolate OPTION values in your strings.
231
232 =subsection Interpolating
233 With the C<__x()> or C<__nx()>, interpolation will take place on the
234 translated MSGID string. The translation can contain the VARIABLE
235 and OPTION names inbetween curly brackets. Text between curly brackets
236 which is not a known parameter will be left untouched.
237
238 Next to the name, you can specify a format code. With C<gettext()>,
239 you often see this:
240
241 printf gettext("approx pi: %.6f\n"), PI;
242
243 M<Locale::TextDomain> has two ways.
244
245 printf __"approx pi: %.6f\n", PI;
246 print __x"approx pi: {approx}\n", approx => sprintf("%.6f", PI);
247
248 The first does not respect the wish to be able to reorder the
249 arguments during translation. The second version is quite long.
250 With C<Log::Report>, above syntaxes do work, but you can also do
251
252 print __x"approx pi: {pi%.6f}\n", pi => PI;
253
254 So: the interpolation syntax is C< { name [format] } >. Other
255 examples:
256
257 print __x "{perms} {links%2d} {user%-8s} {size%10d} {fn}\n"
258 , perms => '-rw-r--r--', links => 1, user => 'me'
259 , size => '12345', fn => $filename;
260
261 An additional advantage is the fact that not all languages produce
262 comparible length strings. Now, the translators can take care that
263 the layout of tables is optimal.
264
265 =subsection Interpolation of OPTIONS
266 You are permitted the interpolate OPTION values in your string. This may
267 simplify your coding. The useful names are:
268
269 =over 4
270 =item _msgid
271 The MSGID as provided with M<Log::Report::__()> and M<Log::Report::__x()>
272
273 =item _msgid, _plural, _count
274 The single MSGID and PLURAL MSGIDs, respectively the COUNT as used with
275 M<Log::Report::__n()> and M<Log::Report::__nx()>
276
277 =item _textdomain
278 The label of the textdomain in which the translation takes place.
279 =back
280
281 =example using the _count
282 With M<Locale::TextDomain>, you have to do
283
284 use Locale::TextDomain;
285 print __nx ( "One file has been deleted.\n"
286 , "{num} files have been deleted.\n"
287 , $num_files
288 , num => $num_files
289 );
290
291 With C<Log::Report>, you can do
292
293 use Log::Report;
294 print __nx ( "One file has been deleted.\n"
295 , "{_count} files have been deleted.\n"
296 , $num_files
297 );
298
299 Of course, you need to be aware that the name used to reference the
300 counter is pixed to C<_count>. The first example works as well, but
301 is more verbose.
302
303 =subsection Interpolation of VARIABLES
304 There is no way of checking beforehand whether you have provided all required
305 values, to be interpolated in the translated string. A translation could be
306 specified like this:
307
308 my @files = @ARGV;
309 local $" = ', ';
310 my $s = __nx "One file specified ({files})"
311 , "{_count} files specified ({files})"
312 , scalar @files # actually, 'scalar' is not needed
313 , files => \@files;
314
315 For interpolating, the following rules apply:
316 =over 4
317 =item .
318 Simple scalar values are interpolated "as is"
319 =item .
320 References to SCALARs will collect the value on the moment that the
321 output is made. The C<Log::Report::Message> object which is created with
322 the C<__xn> can be seen as a closure. The translation can be reused.
323 See example below.
324 =item .
325 Code references can be used to create the data "under fly". The
326 C<Log::Report::Message> object which is being handled is passed as
327 only argument. This is a hash in which all OPTIONS and VARIABLES
328 can be found.
329 =item .
330 When the value is an ARRAY, all members will be interpolated with C<$">
331 inbetween the elements.
332 =back
333
334 =example reducing the number of translations
335 This way of translating is somewhat expensive, because an object to
336 handle the C<__x()> is created each time.
337
338 for my $i (1..100_000)
339 { print __x "Hello World {i}\n", $i;
340 }
341
342 The suggestion that M<Locale::TextDomain> makes to improve performance,
343 is to get the translation outside the loop, which only works without
344 interpolation:
345
346 use Locale::TextDomain;
347 my $i = 42;
348 my $s = __x("Hello World {i}\n", i => $i);
349 foreach $i (1..100_000)
350 { print $s;
351 }
352
353 Oops, not what you mean.
354 With Log::Report, you can do
355
356 use Log::Report;
357 my $i;
358 my $s = __x("Hello World {i}", i => \$i);
359 foreach $i (1..100_000)
360 { print $s;
361 }
362
363 Mind you not to write: C<for my $i> in this case!!!!
364 You can also write an incomplete translation:
365
366 use Log::Report;
367 my $s = __x "Hello World {i}";
368 foreach my $i (1..100_000)
369 { print $s->(i => $i);
370 }
371
372 In either case, the translation will be looked-up only once.
373 =cut
374
375 1;
+60
-0
lib/Log/Report/Translator/Gettext.pm less more
0 use warnings;
1 use strict;
2
3 package Log::Report::Translator::Gettext;
4 use base 'Log::Report::Translator';
5
6 use Locale::gettext;
7 use POSIX qw/setlocale/;
8
9 use Log::Report 'log-report';
10
11 =chapter NAME
12 Log::Report::Translator::Gettext - the GNU gettext infrastructure
13
14 =chapter SYNOPSIS
15 # normal use (end-users view)
16
17 use Log::Report 'my-domain'
18 , translator => Log::Report::Translator::Gettext->new;
19
20 print __"Hello World\n"; # language determined by enviroment
21
22 # internal use
23
24 my $msg = Log::Report::Message->new
25 ( _msgid => "Hello World\n"
26 , _textdomain => 'my-domain'
27 );
28
29 print Log::Report::Translator::Gettext->new
30 ->translate('nl-BE', $msg);
31
32 =chapter DESCRIPTION
33 UNTESTED!!! PLEASE CONTRIBUTE!!!
34 Translate a message using the GNU gettext infrastructure.
35
36 =chapter METHODS
37 =cut
38
39 sub translate($)
40 { my ($msg) = @_;
41
42 my $domain = $msg->{_textdomain};
43 load_domain $domain;
44
45 my $count = $msg->{_count};
46
47 defined $count
48 ? ( defined $msg->{_category}
49 ? dcngettext($domain, $msg->{_msgid}, $msg->{_plural}, $count
50 , $msg->{_category})
51 : dngettext($domain, $msg->{_msgid}, $msg->{_plural}, $count)
52 )
53 : ( defined $msg->{_category}
54 ? dcgettext($domain, $msg->{_msgid}, $msg->{_category})
55 : dgettext($domain, $msg->{_msgid})
56 );
57 }
58
59 1;
+79
-0
lib/Log/Report/Translator/POT.pm less more
0 use warnings;
1 use strict;
2
3 package Log::Report::Translator::POT;
4 use base 'Log::Report::Translator';
5
6 use Log::Report 'log-report', syntax => 'SHORT';
7 use Log::Report::Lexicon::Index;
8
9 use POSIX qw/locale_h/;
10
11 my %indices;
12
13 =chapter NAME
14 Log::Report::Translator::POT - translation based on POT files
15
16 =chapter SYNOPSIS
17 # internal use
18 my $msg = Log::Report::Message->new(_msgid => "Hello World\n"
19 , _domain => 'my-domain');
20 print Log::Report::Translator::POT->new(lexicon => ...)
21 ->translate('nl-BE', $msg);
22
23 # normal use (end-users view)
24 use Log::Report 'my-domain'
25 , translator => Log::Report::Translator::POT->new;
26 print __"Hello World\n";
27
28 =chapter DESCRIPTION
29 Translate a message by directly accessing POT files. The files will
30 load lazily (unless forced). To module attempts to administer the PO's
31 in a compact way, much more compact than M<Log::Report::Lexicon::PO> does.
32
33 =chapter METHODS
34
35 =section Constructors
36
37 =c_method new OPTIONS
38 =cut
39
40 sub translate($)
41 { my ($self, $msg) = @_;
42
43 my $domain = $msg->{_domain};
44 my $locale = setlocale(LC_MESSAGES, '');
45 my $pot = exists $self->{pots}{$locale} ? $self->{pots}{$locale}
46 : $self->load($domain, $locale);
47
48 defined $pot
49 or return $self->SUPER::translate($msg);
50
51 $pot->msgstr($msg->{_msgid}, $msg->{_count})
52 || return $self->SUPER::translate($msg);
53 }
54
55 sub load($$)
56 { my ($self, $domain, $locale) = @_;
57
58 foreach my $lex ($self->lexicons)
59 { my $potfn = $lex->find($domain, $locale);
60 if($potfn)
61 { my $po = Log::Report::Lexicon::POTcompact
62 ->read($potfn, charset => $self->charset);
63
64 info __x "read pot-file {filename} for {domain} in {locale}"
65 , filename => $potfn, domain => $domain, locale => $locale
66 if $domain ne 'log-report'; # avoid recursion
67
68 return $self->{pots}{$locale} = $po;
69 }
70
71 # there are tables for domain, but not ours
72 last if $lex->list($domain);
73 }
74
75 $self->{pots}{$locale} = undef
76 }
77
78 1;
+137
-0
lib/Log/Report/Translator.pm less more
0 package Log::Report::Translator;
1
2 use warnings;
3 use strict;
4
5 use File::Spec ();
6
7 use Log::Report 'log-report', syntax => 'SHORT';
8
9 use Log::Report::Lexicon::Index ();
10
11 my %lexicons;
12
13 sub _filename_to_lexicon($);
14
15 =chapter NAME
16 Log::Report::Translator - base implementation for translating messages
17
18 =chapter SYNOPSIS
19 # internal infrastructure
20 my $msg = Log::Report::Message->new(_msgid => "Hello World\n");
21 print Log::Report::Translator->new(...)->translate($msg);
22
23 # normal use
24 use Log::Report 'my-domain';
25 print __"Hello World\n";
26
27 =chapter DESCRIPTION
28 A module (or distribution) has a certain way of translating messages,
29 usually C<gettext>. The translator is based on the C<textdomain>
30 for the message, which can be specified as option per text element,
31 but usually is package scoped.
32
33 This base class does not translate at all: it will use the MSGID
34 (and MSGID_PLURAL if available). It's a nice fallback if the
35 language packs are not installed.
36
37 =chapter METHODS
38
39 =section Constructors
40
41 =c_method new OPTIONS
42 =option lexicon DIRECTORY|ARRAY-of-DIRECTORYs
43 =default lexicon <see text>
44 The DIRECTORY where the translations can be found. See
45 M<Log::Report::Lexicon::Index> for the expected structure of such
46 DIRECTORY.
47
48 The default is based on the location of the module which instantiates
49 this translator. The filename of the module is stripped from its C<.pm>
50 extension, and used as directory name. Within that directory, there
51 must be a directory named C<messages>, which will be the root directory
52 of a M<Log::Report::Lexicon::Index>.
53
54 =option charset STRING
55 =default charset <from locale>
56 When the locale contains a codeset in its name, then that will be
57 used. Otherwise, the default is C<utf-8>.
58
59 =example default lexicon directory
60 # file xxx/perl5.8.8/My/Module.pm
61 use Log::Report 'my-domain',
62 translator => Log::Report::Translator::POT->new;
63
64 # lexicon now in xxx/perl5.8.8/My/Module/messages/
65 =cut
66
67 sub new(@)
68 { my $class = shift;
69 (bless {}, $class)->init( {callerfn => (caller)[1], @_} );
70 }
71
72 sub init($)
73 { my ($self, $args) = @_;
74 my $lex = delete $args->{lexicons}
75 || _filename_to_lexicon $args->{callerfn};
76
77 my @lex;
78 foreach my $lex (ref $lex eq 'ARRAY' ? @$lex : $lex)
79 { push @lex, $lexicons{$lex} ||= # lexicon indexes are shared
80 Log::Report::Lexicon::Index->new($lex);
81 }
82 $self->{lexicons} = \@lex;
83 $self->{charset} = $args->{charset} || 'utf-8';
84 $self;
85 }
86
87 sub _filename_to_lexicon($)
88 { my $fn = shift;
89 $fn =~ s/\.pm$//;
90 File::Spec->catdir($fn, 'messages');
91 }
92
93 =section Accessors
94
95 =method lexicons
96 Returns a list of M<Log::Report::Lexicon::Index> objects, where the
97 translation files may be located.
98 =cut
99
100 sub lexicons() { @{shift->{lexicons}} }
101
102 =method charset
103 Returns the default charset, which can be overrule by the locale.
104 =cut
105
106 sub charset() {shift->{charset}}
107
108 =section Translating
109
110 =method translate MESSAGE
111 Returns the translation of the MESSAGE, a C<Log::Report::Message> object,
112 based on the current locale.
113
114 Translators are permitted to peek into the internal HASH of the
115 message object, for performance reasons.
116 =cut
117
118 # this is called as last resort: if a translator cannot find
119 # any lexicon or has no matching language.
120 sub translate($)
121 { my $msg = $_[1];
122
123 defined $msg->{_count} && $msg->{_count} != 1
124 ? $msg->{_plural}
125 : $msg->{_msgid};
126 }
127
128 =method load DOMAIN, LOCALE
129 Load the translation information in the text DOMAIN for the indicated LOCALE.
130 Multiple calls to M<load()> should not cost significant performance: the
131 data must be cached.
132 =cut
133
134 sub load($@) { undef }
135
136 1;
+127
-0
lib/Log/Report/Util.pm less more
0
1 use warnings;
2 use strict;
3
4 package Log::Report::Util;
5 use base 'Exporter';
6
7 our @EXPORT = qw/@reasons %reason_code parse_locale expand_reasons
8 escape_chars unescape_chars/;
9
10 use Log::Report 'log-report', syntax => 'SHORT';
11
12 # ordered!
13 our @reasons = N__w('TRACE ASSERT INFO NOTICE WARNING
14 MISTAKE ERROR FAULT ALERT FAILURE PANIC');
15 our %reason_code; { my $i=1; %reason_code = map { ($_ => $i++) } @reasons }
16
17 my @user = qw/MISTAKE ERROR/;
18 my @program = qw/TRACE ASSERT INFO NOTICE WARNING PANIC/;
19 my @system = qw/FAULT ALERT FAILURE/;
20
21 =chapter NAME
22 Log::Report::Util - helpful routines to Log::Report
23
24 =chapter SYNOPSYS
25 my ($language, $territory, $charset, $modifier)
26 = parse_locale 'nl_BE.utf-8@home';
27
28 my @take = expand_reasons 'INFO-ERROR,PANIC';
29
30 =chapter DESCRIPTION
31
32 =chapter FUNCTIONS
33
34 =function parse_locale STRING
35 Returns a LIST of four elements when successful, and an empty
36 LIST when the locale is not correct. The LIST order is country,
37 territory, character-set (codeset), and modifier.
38 =cut
39
40 sub parse_locale($)
41 { $_[0] =~
42 m/^ ([a-z]{2}) # ISO 631
43 (?: \_ ([a-zA-Z\d]+) # ISO 3166
44 (?: \. ([\w-]+) )? # codeset
45 )?
46 (?: \@ (\S+) )? # modifier
47 $
48 /x;
49 }
50
51 =function expand_reasons REASONS
52 Returns a sub-set of all existing message reason labels, based on the
53 content REASONS string. The following rules apply:
54 REASONS = BLOCK [ ',' BLOCKS]
55 BLOCK = '-' TO | FROM '-' TO | ONE | SOURCE
56 FROM,TO,ONE = 'TRACE' | 'ASSERT' | ,,, | 'PANIC'
57 SOURCE = 'USER' | 'PROGRAM' | 'SYSTEM' | 'ALL'
58
59 The SOURCE specification group all reasons which are usually related to
60 the problem: report about problems caused by the user, reported by
61 the program, or with system interaction.
62
63 =examples of expended REASONS
64 WARNING-FAULT # == WARNING,MISTAKE,ERROR,FAULT
65 -INFO # == TRACE-INFO
66 ALERT- # == ALERT,FAILURE,PANIC
67 USER # == MISTAKE,ERROR
68 ALL # == TRACE-PANIC
69 =cut
70
71 sub expand_reasons($)
72 { my $reasons = shift;
73 my %r;
74 foreach my $r (split m/\,/, $reasons)
75 { if($r =~ m/^([a-z]*)\-([a-z]*)/i )
76 { my $begin = $reason_code{$1 || 'TRACE'};
77 my $end = $reason_code{$2 || 'PANIC'};
78 $begin && $end
79 or error __x"unknown reason {which} in '{reasons}'"
80 , which => ($begin ? $2 : $1), reasons => $reasons;
81
82 error __x"reason '{begin}' more serious than '{end}' in '{reasons}"
83 , begin => $1, end => $2, reasons => $reasons
84 if $begin >= $end;
85
86 $r{$_}++ for $begin..$end;
87 }
88 elsif($reason_code{$r}) { $r{$reason_code{$r}}++ }
89 elsif($r eq 'USER') { $r{$reason_code{$_}}++ for @user }
90 elsif($r eq 'PROGRAM') { $r{$reason_code{$_}}++ for @program }
91 elsif($r eq 'SYSTEM') { $r{$reason_code{$_}}++ for @system }
92 elsif($r eq 'ALL') { $r{$reason_code{$_}}++ for @reasons }
93 else
94 { error __x"unknown reason {which} in '{reasons}'"
95 , which => $r, reasons => $reasons;
96 }
97 }
98 (undef, @reasons)[sort {$a <=> $b} keys %r];
99 }
100
101 =function escape_chars STRING
102 Replace all escape characters into their readible counterpart.
103
104 =function unescape_chars STRING
105 Replace all C<\.> by their escape character.
106 =cut
107
108 my %unescape
109 = ( '\a' => "\a", '\b' => "\b", '\f' => "\f", '\n' => "\n"
110 , '\r' => "\r", '\t' => "\t", '\"' => '"', '\\\\' => '\\'
111 , '\e' => "\x1b", '\v' => "\x0b"
112 );
113 my %escape = reverse %unescape;
114
115 sub escape_chars($)
116 { my $str = shift;
117 $str =~ s/([\x00-\x1F"\\])/$escape{$1} || '?'/ge;
118 $str;
119 }
120
121 sub unescape_chars($)
122 { my $str = shift;
123 $str =~ s/(\\.)/$unescape{$1} || $1/ge;
124 $str;
125 }
126
+279
-0
lib/Log/Report/messages/log-report/nl_NL.po less more
0 #. Header generated with Log::Report::Lexicon::POT 0.0
1 msgid ""
2 msgstr ""
3 "Project-Id-Version: log-report 0.01\n"
4 "Report-Msgid-Bugs-To:\n"
5 "POT-Creation-Date: 2007-05-14 17:14+0200\n"
6 "PO-Revision-Date: 2007-05-28 00:48+0200\n"
7 "Last-Translator: Mark Overmeer <mark@overmeer.net>\n"
8 "Language-Team:\n"
9 "MIME-Version: 1.0\n"
10 "Content-Type: text/plain; charset=utf-8\n"
11 "Content-Transfer-Encoding: 8bit\n"
12 "Plural-Forms: nplurals=2; plural=(n!=1);\n"
13
14 #: lib/Log/Report/Util.pm:14
15 msgid "ALERT"
16 msgstr "ALARM"
17
18 #: lib/Log/Report/Util.pm:14
19 msgid "ASSERT"
20 msgstr "CONDITIE"
21
22 #: lib/Log/Report/Util.pm:14
23 msgid "ERROR"
24 msgstr "ERROR"
25
26 #: lib/Log/Report/Util.pm:14
27 msgid "FAILURE"
28 msgstr "STORING"
29
30 #: lib/Log/Report/Util.pm:14
31 msgid "FAULT"
32 msgstr "PROBLEEM"
33
34 #: lib/Log/Report/Util.pm:14
35 msgid "INFO"
36 msgstr "INFO"
37
38 #: lib/Log/Report/Dispatcher/LogDispatch.pm:105
39 msgid "Log::Dispatch level '{level}' not understood"
40 msgstr "Log::Dispatch level '{level}' niet herkend"
41
42 #: lib/Log/Report/Dispatcher/Log4perl.pm:100
43 msgid "Log::Log4perl back-end {name} requires a 'config' parameter"
44 msgstr "Log::Log4perl back-end {name} verwacht een 'config' argument"
45
46 #: lib/Log/Report/Dispatcher/Log4perl.pm:111
47 msgid "Log::Log4perl level '{level}' must be in 0-5"
48 msgstr "Log::Log4perl level '{level}' is getal van 0 tot 5"
49
50 #: lib/Log/Report/Util.pm:14
51 msgid "MISTAKE"
52 msgstr "FOUT"
53
54 #: lib/Log/Report/Util.pm:14
55 msgid "NOTICE"
56 msgstr "OPGELET"
57
58 #: lib/Log/Report/Dispatcher/Log4perl.pm:27
59 #: lib/Log/Report/Dispatcher/LogDispatch.pm:27
60 #: lib/Log/Report/Dispatcher/Syslog.pm:28
61 msgid "Not all reasons have a default translation"
62 msgstr "Niet alle redenen hebben een default vertaling"
63
64 #: lib/Log/Report/Util.pm:14
65 msgid "PANIC"
66 msgstr "PANIEK"
67
68 #: lib/Log/Report/Extract/PerlPPI.pm:112
69 msgid "PPI only supports iso-8859-1 (latin-1) on the moment"
70 msgstr "PPI ondersteunt momenteel alleen iso-8859-1 (latin-1)"
71
72 #: lib/Log/Report/Extract/PerlPPI.pm:67
73 msgid "PerlPPI requires explicit lexicon directory"
74 msgstr "PerlPPI verwacht een expliciet vermeldde lexicon directory"
75
76 #: lib/Log/Report/Util.pm:14
77 msgid "TRACE"
78 msgstr "TRACE"
79
80 #: lib/Log/Report.pm:200
81 msgid "Token '{token}' not recognized as reason"
82 msgstr "'{token}' is niet herkend als rapportage reden"
83
84 #: lib/Log/Report/Util.pm:14
85 msgid "WARNING"
86 msgstr "WAARSCHUWING"
87
88 #: lib/Log/Report/Dispatcher.pm:244 lib/Log/Report/Dispatcher.pm:255
89 msgid "at {filename} line {line}"
90 msgstr "in {filename} regel {line}"
91
92 #: lib/Log/Report/Extract/PerlPPI.pm:70
93 msgid "cannot create lexicon directory {dir}"
94 msgstr "kan lexicon map {dir} niet aanmaken"
95
96 #: lib/Log/Report/Dispatcher/Log4perl.pm:121
97 msgid "cannot find logger '{name}' in configuration {config}"
98 msgstr "kan logger '{name}' in configuratie {config} niet vinden"
99
100 #: lib/Log/Report/Extract/PerlPPI.pm:115
101 msgid "cannot read from file {filename}"
102 msgstr "kan bestand {filename} niet lezen"
103
104 #: lib/Log/Report/Lexicon/POT.pm:147 lib/Log/Report/Lexicon/POTcompact.pm:69
105 msgid "cannot read in {cs} from file {fn}"
106 msgstr "kan bestand {fn} niet lezen in {cs}"
107
108 #: lib/Log/Report/Dispatcher/File.pm:85
109 msgid "cannot write log into {file} with {binmode}"
110 msgstr "kan log niet naar bestand {file} schrijven in {binmode}"
111
112 #: lib/Log/Report/Lexicon/POT.pm:197
113 msgid "cannot write to file {fn} in {layers}"
114 msgstr "kan bestand {fn} niet schrijven in {layers}"
115
116 #: lib/Log/Report/Lexicon/POT.pm:108 lib/Log/Report/Lexicon/POT.pm:144
117 msgid "charset parameter is required for {fn}"
118 msgstr "charset argument is verplicht voor {fn}"
119
120 #: lib/Log/Report/Lexicon/POTcompact.pm:66
121 msgid "charset parameter required for {fn}"
122 msgstr ""
123
124 #: lib/Log/Report/Dispatcher/File.pm:72
125 msgid "dispatcher {name} needs parameter 'to'"
126 msgstr "dispatcher {name} verwacht argument 'to'"
127
128 #: lib/Log/Report/Lexicon/PO.pm:348
129 msgid "do not understand command '{cmd}' at {where}"
130 msgstr "commando '{cmd}' op plaats {where} niet begrepen"
131
132 #: lib/Log/Report/Lexicon/PO.pm:365
133 msgid "do not understand line at {where}:\\n {line}"
134 msgstr "regel op plaats {where} niet begrepen:\\n {line}"
135
136 #: lib/Log/Report/Lexicon/POT.pm:164 lib/Log/Report/Lexicon/POTcompact.pm:106
137 msgid "failed reading from file {fn}"
138 msgstr "lezen uit bestand {fn} mislukt"
139
140 #: lib/Log/Report/Extract/PerlPPI.pm:294
141 msgid "found one pot file for domain {domain}"
142 msgid_plural "found {_count} pot files for domain {domain}"
143 msgstr[0] "één pot bestand voor domein {domain} gevonden"
144 msgstr[1] "{_count} pot bestanden voor domain {domain} gevonden"
145
146 #: lib/Log/Report.pm:350
147 msgid "in SCALAR context, only one dispatcher name accepted"
148 msgstr "in SCALAR context kan slechts één dispatcher naam worden gebruikt"
149
150 #: lib/Log/Report/Lexicon/POTcompact.pm:183
151 msgid "invalid plural-form algorithm '{alg}'"
152 msgstr "incorrect meervoudsvorm algoritme '{alg}'"
153
154 #: lib/Log/Report/Lexicon/POT.pm:188
155 msgid "no filename or file-handle specified for PO"
156 msgstr "geen bestandsnaam of -handle meegegeven voor PO"
157
158 #: lib/Log/Report/Lexicon/POT.pm:323
159 msgid "no header defined in POT for file {fn}"
160 msgstr "geen kop opgegeven in POT in bestand {fn}"
161
162 #: lib/Log/Report/Lexicon/PO.pm:370
163 msgid "no msgid in block {where}"
164 msgstr "geen msgid in blok {where}"
165
166 #: lib/Log/Report/Lexicon/PO.pm:445
167 msgid "no plurals for '{msgid}'"
168 msgstr "geen meervoudsvormen voor '{msgid}'"
169
170 #: lib/Log/Report/Extract/PerlPPI.pm:155
171 msgid "no textdomain for translatable at {fn} line {line}"
172 msgstr "geen textdomain voor vertaling in {fn} regel {line}"
173
174 #: lib/Log/Report/Extract/PerlPPI.pm:109
175 msgid "processing file {fn} in {charset}"
176 msgstr "verwerk bestand {fn} in {charset}"
177
178 #: lib/Log/Report/Lexicon/PO.pm:360
179 msgid "quoted line is not a continuation at {where}"
180 msgstr "regel met quotes is geen voortzetting in {where}"
181
182 #: lib/Log/Report/Translator/POT.pm:65
183 msgid "read pot-file {filename} for {domain} in {locale}"
184 msgstr "lees pot bestand {filename} voor {domain} in {locale}"
185
186 #: lib/Log/Report/Util.pm:83
187 msgid "reason '{begin}' more serious than '{end}' in '{reasons}"
188 msgstr "reden '{begin}' is serieuzer dan '{end}' in '{reasons}'"
189
190 #: lib/Log/Report/Extract/PerlPPI.pm:302
191 msgid "starting new textdomain {domain}, template in {filename}"
192 msgstr "begin van nieuw textdomain {domain}, sjabloon in {filename}"
193
194 #: lib/Log/Report/Lexicon/POTcompact.pm:195
195 msgid "string '{text}' not between quotes at {location}"
196 msgstr "tekst '{text}' niet tussen quotes in {location}"
197
198 #: lib/Log/Report/Dispatcher.pm:166
199 msgid "switching to run mode {mode}"
200 msgstr "overschakeling naar verwerkingsmode {mode}"
201
202 #: lib/Log/Report/Dispatcher/Syslog.pm:105
203 msgid "syslog level '{level}' not understood"
204 msgstr "syslog level '{level}' niet herkend."
205
206 #: lib/Log/Report.pm:732
207 msgid "textdomain '{domain}' configured twice. First: {fn} line {nr}"
208 msgstr "tekstdomein '{domain}' wordt twee maal geconfigureerd. Eerste keer in {fn} regel {nr}"
209
210 #: lib/Log/Report.pm:725
211 msgid "textdomain for translator not defined"
212 msgstr "tekstdomein voor vertaler niet gedefinieerd"
213
214 #: lib/Log/Report/Lexicon/POT.pm:113
215 msgid "textdomain parameter is required"
216 msgstr "tekstdomain argument is verplicht"
217
218 #: lib/Log/Report.pm:341
219 msgid "the 'filter' sub-command needs a CODE reference"
220 msgstr "het 'filter' sub-commando verwacht een CODE referentie"
221
222 #: lib/Log/Report.pm:328
223 msgid "the 'list' sub-command doesn't expect additional parameters"
224 msgstr "het 'list' sub-commando verwacht geen aanvullende argumenten"
225
226 #: lib/Log/Report.pm:334
227 msgid "the 'needs' sub-command parameter '{reason}' is not a reason"
228 msgstr "het 'needs' sub-commando argument '{reason}' is geen reden"
229
230 #: lib/Log/Report/Lexicon/POT.pm:283
231 msgid "the only acceptable parameter is 'ACTIVE', not '{p}'"
232 msgstr "het enige geaccepteerde argument is 'ACTIVE', niet '{p}'"
233
234 #: lib/Log/Report/Lexicon/PO.pm:434
235 msgid "too many plurals for '{msgid}'"
236 msgstr "te veel meervouden voor '{msgid}'"
237
238 #: lib/Log/Report/Lexicon/POT.pm:266
239 msgid "translation already exists for '{msgid}'"
240 msgstr "er bestaat al een vertaling voor '{msgid}'"
241
242 #: lib/Log/Report.pm:737
243 msgid "translator must be a Log::Report::Translator object"
244 msgstr "vertaler moet een Log::Report::Translator object zijn"
245
246 #: lib/Log/Report/Lexicon/PO.pm:326
247 msgid "unknown comment type '{cmd}' at {where}"
248 msgstr "onbekend commentaar type '{cmd}' in {where}"
249
250 #: lib/Log/Report/Lexicon/PO.pm:294
251 msgid "unknown flag {flag} ignored"
252 msgstr "onbekende vlag {flag} wordt genegeerd"
253
254 #: lib/Log/Report/Util.pm:80 lib/Log/Report/Util.pm:95
255 msgid "unknown reason {which} in '{reasons}'"
256 msgstr "onbekende reden {which} is '{reasons}'"
257
258 #: lib/Log/Report/Dispatcher.pm:164
259 msgid "unknown run mode '{mode}'"
260 msgstr "onbekende verwerkingsmode '{mode}'"
261
262 #: lib/Log/Report/Lexicon/POT.pm:109
263 msgid "unnamed file"
264 msgstr ""
265
266 #: lib/Log/Report/Lexicon/POT.pm:209
267 msgid "write errors for file {fn}"
268 msgstr "schrijfproblemen bij bestand {fn}"
269
270 #: lib/Log/Report/Extract/PerlPPI.pm:242
271 msgid "{domain}: one file with {ids} msgids, {f} fuzzy and {i} inactive translations"
272 msgid_plural "{domain}: {_count} files each {ids} msgids, {f} fuzzy and {i} inactive translations in total"
273 msgstr[0] "{domain}: één bestand met {ids} mgsids, {f} fuzzy en {i} op non-aktief"
274 msgstr[1] "{domain}: {_count} bestanden met elk {ids} msgids, {f} fuzzy en {i} op non-aktief in het totaal"
275
276 #: lib/Log/Report/Extract/PerlPPI.pm:233
277 msgid "{domain}: {fuzzy%3d} fuzzy, {inact%3d} inactive in {filename}"
278 msgstr "{domain}: {fuzzy%3d} fuzzy, {inact%3d} op non-aktief in {filename}"
+374
-0
lib/Log/Report/messages/log-report.utf-8.po less more
0 #. Header generated with Log::Report::Lexicon::POT 0.0
1 msgid ""
2 msgstr ""
3 "Project-Id-Version: log-report 0.01\n"
4 "Report-Msgid-Bugs-To:\n"
5 "POT-Creation-Date: 2007-05-14 17:14+0200\n"
6 "PO-Revision-Date: 2007-05-28 00:48+0200\n"
7 "Last-Translator:\n"
8 "Language-Team:\n"
9 "MIME-Version: 1.0\n"
10 "Content-Type: text/plain; charset=utf-8\n"
11 "Content-Transfer-Encoding: 8bit\n"
12 "Plural-Forms: nplurals=2; plural=(n!=1);\n"
13
14 #: lib/Log/Report/Util.pm:14
15 #, fuzzy
16 msgid "ALERT"
17 msgstr ""
18
19 #: lib/Log/Report/Util.pm:14
20 #, fuzzy
21 msgid "ASSERT"
22 msgstr ""
23
24 #: lib/Log/Report/Util.pm:14
25 #, fuzzy
26 msgid "ERROR"
27 msgstr ""
28
29 #: lib/Log/Report/Util.pm:14
30 #, fuzzy
31 msgid "FAILURE"
32 msgstr ""
33
34 #: lib/Log/Report/Util.pm:14
35 #, fuzzy
36 msgid "FAULT"
37 msgstr ""
38
39 #: lib/Log/Report/Util.pm:14
40 #, fuzzy
41 msgid "INFO"
42 msgstr ""
43
44 #: lib/Log/Report/Dispatcher/LogDispatch.pm:105
45 #, fuzzy
46 msgid "Log::Dispatch level '{level}' not understood"
47 msgid_plural "level"
48 msgstr[0] ""
49 msgstr[1] ""
50
51 #: lib/Log/Report/Dispatcher/Log4perl.pm:100
52 #, fuzzy
53 msgid "Log::Log4perl back-end {name} requires a 'config' parameter"
54 msgstr ""
55
56 #, fuzzy
57 #~ msgid "Log::Log4perl back-end {name} requires a config argument"
58 #~ msgstr ""
59
60 #: lib/Log/Report/Dispatcher/Log4perl.pm:111
61 #, fuzzy
62 msgid "Log::Log4perl level '{level}' must be in 0-5"
63 msgstr ""
64
65 #: lib/Log/Report/Util.pm:14
66 #, fuzzy
67 msgid "MISTAKE"
68 msgstr ""
69
70 #: lib/Log/Report/Util.pm:14
71 #, fuzzy
72 msgid "NOTICE"
73 msgstr ""
74
75 #: lib/Log/Report/Dispatcher/Log4perl.pm:27
76 #: lib/Log/Report/Dispatcher/LogDispatch.pm:27
77 #: lib/Log/Report/Dispatcher/Syslog.pm:28
78 #, fuzzy
79 msgid "Not all reasons have a default translation"
80 msgstr ""
81
82 #: lib/Log/Report/Util.pm:14
83 #, fuzzy
84 msgid "PANIC"
85 msgstr ""
86
87 #: lib/Log/Report/Extract/PerlPPI.pm:112
88 #, fuzzy
89 msgid "PPI only supports iso-8859-1 (latin-1) on the moment"
90 msgstr ""
91
92 #: lib/Log/Report/Extract/PerlPPI.pm:67
93 #, fuzzy
94 msgid "PerlPPI requires explicit lexicon directory"
95 msgstr ""
96
97 #: lib/Log/Report/Util.pm:14
98 #, fuzzy
99 msgid "TRACE"
100 msgstr ""
101
102 #: lib/Log/Report.pm:200
103 #, fuzzy
104 msgid "Token '{token}' not recognized as reason"
105 msgstr ""
106
107 #: lib/Log/Report/Util.pm:14
108 #, fuzzy
109 msgid "WARNING"
110 msgstr ""
111
112 #: lib/Log/Report/Dispatcher.pm:244 lib/Log/Report/Dispatcher.pm:255
113 #, fuzzy
114 msgid "at {filename} line {line}"
115 msgstr ""
116
117 #: lib/Log/Report/Extract/PerlPPI.pm:70
118 #, fuzzy
119 msgid "cannot create lexicon directory {dir}"
120 msgstr ""
121
122 #: lib/Log/Report/Dispatcher/Log4perl.pm:121
123 #, fuzzy
124 msgid "cannot find logger '{name}' in configuration {config}"
125 msgstr ""
126
127 #: lib/Log/Report/Extract/PerlPPI.pm:115
128 #, fuzzy
129 msgid "cannot read from file {filename}"
130 msgstr ""
131
132 #: lib/Log/Report/Lexicon/POT.pm:147 lib/Log/Report/Lexicon/POTcompact.pm:69
133 #, fuzzy
134 msgid "cannot read in {cs} from file {fn}"
135 msgstr ""
136
137 #: lib/Log/Report/Dispatcher/File.pm:85
138 #, fuzzy
139 msgid "cannot write log into {file} with {binmode}"
140 msgstr ""
141
142 #: lib/Log/Report/Lexicon/POT.pm:197
143 #, fuzzy
144 msgid "cannot write to file {fn} in {layers}"
145 msgstr ""
146
147 #: lib/Log/Report/Lexicon/POT.pm:108 lib/Log/Report/Lexicon/POT.pm:144
148 #, fuzzy
149 msgid "charset parameter is required for {fn}"
150 msgstr ""
151
152 #: lib/Log/Report/Lexicon/POTcompact.pm:66
153 #, fuzzy
154 msgid "charset parameter required for {fn}"
155 msgstr ""
156
157 #: lib/Log/Report/Dispatcher/File.pm:72
158 #, fuzzy
159 msgid "dispatcher {name} needs parameter 'to'"
160 msgstr ""
161
162 #: lib/Log/Report/Lexicon/PO.pm:348
163 #, fuzzy
164 msgid "do not understand command '{cmd}' at {where}"
165 msgstr ""
166
167 #: lib/Log/Report/Lexicon/PO.pm:365
168 #, fuzzy
169 msgid "do not understand line at {where}:\\n {line}"
170 msgstr ""
171
172 #: lib/Log/Report/Lexicon/POT.pm:164 lib/Log/Report/Lexicon/POTcompact.pm:106
173 #, fuzzy
174 msgid "failed reading from file {fn}"
175 msgstr ""
176
177 #: lib/Log/Report/Extract/PerlPPI.pm:294
178 #, fuzzy
179 msgid "found one pot file for domain {domain}"
180 msgid_plural "found {_count} pot files for domain {domain}"
181 msgstr[0] ""
182 msgstr[1] ""
183
184 #: lib/Log/Report.pm:350
185 #, fuzzy
186 msgid "in SCALAR context, only one dispatcher name accepted"
187 msgstr ""
188
189 #: lib/Log/Report/Lexicon/POTcompact.pm:183
190 #, fuzzy
191 msgid "invalid plural-form algorithm '{alg}'"
192 msgstr ""
193
194 #: lib/Log/Report/Lexicon/POT.pm:188
195 #, fuzzy
196 msgid "no filename or file-handle specified for PO"
197 msgstr ""
198
199 #: lib/Log/Report/Lexicon/POT.pm:323
200 #, fuzzy
201 msgid "no header defined in POT for file {fn}"
202 msgstr ""
203
204 #: lib/Log/Report/Lexicon/PO.pm:370
205 #, fuzzy
206 msgid "no msgid in block {where}"
207 msgstr ""
208
209 #: lib/Log/Report/Lexicon/PO.pm:445
210 #, fuzzy
211 msgid "no plurals for '{msgid}'"
212 msgstr ""
213
214 #, fuzzy
215 #~ msgid "no reason found in report parameters"
216 #~ msgstr ""
217
218 #: lib/Log/Report/Extract/PerlPPI.pm:155
219 #, fuzzy
220 msgid "no textdomain for translatable at {fn} line {line}"
221 msgstr ""
222
223 #, fuzzy
224 #~ msgid "not a CODE reference: {param}"
225 #~ msgstr ""
226
227 #: lib/Log/Report/Extract/PerlPPI.pm:109
228 #, fuzzy
229 msgid "processing file {fn} in {charset}"
230 msgstr ""
231
232 #: lib/Log/Report/Lexicon/PO.pm:360
233 #, fuzzy
234 msgid "quoted line is not a continuation at {where}"
235 msgstr ""
236
237 #: lib/Log/Report/Translator/POT.pm:65
238 #, fuzzy
239 msgid "read pot-file {filename} for {domain} in {locale}"
240 msgstr ""
241
242 #: lib/Log/Report/Util.pm:83
243 #, fuzzy
244 msgid "reason '{begin}' more serious than '{end}' in '{reasons}"
245 msgstr ""
246
247 #: lib/Log/Report/Extract/PerlPPI.pm:302
248 #, fuzzy
249 msgid "starting new textdomain {domain}, template in {filename}"
250 msgstr ""
251
252 #: lib/Log/Report/Lexicon/POTcompact.pm:195
253 #, fuzzy
254 msgid "string '{text}' not between quotes at {location}"
255 msgstr ""
256
257 #, fuzzy
258 #~ msgid "sub-command 'mode' expects name and setting"
259 #~ msgstr ""
260
261 #: lib/Log/Report/Dispatcher.pm:166
262 #, fuzzy
263 msgid "switching to run mode {mode}"
264 msgstr ""
265
266 #, fuzzy
267 #~ msgid "syslog level '$level' not understood"
268 #~ msgstr ""
269
270 #: lib/Log/Report/Dispatcher/Syslog.pm:105
271 #, fuzzy
272 msgid "syslog level '{level}' not understood"
273 msgstr ""
274
275 #: lib/Log/Report.pm:732
276 #, fuzzy
277 msgid "textdomain '{domain}' configured twice. First: {fn} line {nr}"
278 msgstr ""
279
280 #: lib/Log/Report.pm:725
281 #, fuzzy
282 msgid "textdomain for translator not defined"
283 msgstr ""
284
285 #: lib/Log/Report/Lexicon/POT.pm:113
286 #, fuzzy
287 msgid "textdomain parameter is required"
288 msgstr ""
289
290 #: lib/Log/Report.pm:341
291 #, fuzzy
292 msgid "the 'filter' sub-command needs a CODE reference"
293 msgstr ""
294
295 #: lib/Log/Report.pm:328
296 #, fuzzy
297 msgid "the 'list' sub-command doesn't expect additional parameters"
298 msgstr ""
299
300 #, fuzzy
301 #~ msgid "the 'needs' sub-command parameter '{reason} is not a reason"
302 #~ msgstr ""
303
304 #: lib/Log/Report.pm:334
305 #, fuzzy
306 msgid "the 'needs' sub-command parameter '{reason}' is not a reason"
307 msgstr ""
308
309 #: lib/Log/Report/Lexicon/POT.pm:283
310 #, fuzzy
311 msgid "the only acceptable parameter is 'ACTIVE', not '{p}'"
312 msgstr ""
313
314 #: lib/Log/Report/Lexicon/PO.pm:434
315 #, fuzzy
316 msgid "too many plurals for '{msgid}'"
317 msgstr ""
318
319 #: lib/Log/Report/Lexicon/POT.pm:266
320 #, fuzzy
321 msgid "translation already exists for '{msgid}'"
322 msgstr ""
323
324 #: lib/Log/Report.pm:737
325 #, fuzzy
326 msgid "translator must be a Log::Report::Translator object"
327 msgstr ""
328
329 #: lib/Log/Report/Lexicon/PO.pm:326
330 #, fuzzy
331 msgid "unknown comment type '{cmd}' at {where}"
332 msgstr ""
333
334 #, fuzzy
335 #~ msgid "unknown dispatcher {type}"
336 #~ msgstr ""
337
338 #: lib/Log/Report/Lexicon/PO.pm:294
339 #, fuzzy
340 msgid "unknown flag {flag} ignored"
341 msgstr ""
342
343 #: lib/Log/Report/Util.pm:80 lib/Log/Report/Util.pm:95
344 #, fuzzy
345 msgid "unknown reason {which} in '{reasons}'"
346 msgstr ""
347
348 #: lib/Log/Report/Dispatcher.pm:164
349 #, fuzzy
350 msgid "unknown run mode '{mode}'"
351 msgstr ""
352
353 #: lib/Log/Report/Lexicon/POT.pm:109
354 #, fuzzy
355 msgid "unnamed file"
356 msgstr ""
357
358 #: lib/Log/Report/Lexicon/POT.pm:209
359 #, fuzzy
360 msgid "write errors for file {fn}"
361 msgstr ""
362
363 #: lib/Log/Report/Extract/PerlPPI.pm:242
364 #, fuzzy
365 msgid "{domain}: one file with {ids} msgids, {f} fuzzy and {i} inactive translations"
366 msgid_plural "{domain}: {_count} files each {ids} msgids, {f} fuzzy and {i} inactive translations in total"
367 msgstr[0] ""
368 msgstr[1] ""
369
370 #: lib/Log/Report/Extract/PerlPPI.pm:233
371 #, fuzzy
372 msgid "{domain}: {fuzzy%3d} fuzzy, {inact%3d} inactive in {filename}"
373 msgstr ""
+1181
-0
lib/Log/Report.pm less more
0
1 use warnings;
2 use strict;
3
4 package Log::Report;
5 use base 'Exporter';
6
7 # domain 'log-report' via work-arounds:
8 # Log::Report cannot do "use Log::Report"
9
10 use POSIX qw/setlocale LC_ALL/;
11
12 my @make_msg = qw/__ __x __n __nx __xn N__ N__n N__w/;
13 my @functions = qw/report dispatcher try/;
14 my @reason_functions = qw/trace assert info notice warning
15 mistake error fault alert failure panic/;
16
17 our @EXPORT_OK = (@make_msg, @functions, @reason_functions);
18
19 require Log::Report::Util;
20 require Log::Report::Message;
21 require Log::Report::Dispatcher;
22
23 # See chapter Run modes
24 my %is_reason = map {($_=>1)} @Log::Report::Util::reasons;
25 my %is_fatal = map {($_=>1)} qw/ERROR FAULT FAILURE PANIC/;
26 my %use_errno = map {($_=>1)} qw/WARNING FAULT ALERT FAILURE/;
27
28 sub _whats_needed(); sub dispatcher($@);
29 sub trace(@); sub assert(@); sub info(@); sub notice(@); sub warning(@);
30 sub mistake(@); sub error(@); sub fault(@); sub alert(@); sub failure(@);
31 sub panic(@);
32 sub __($); sub __x($@); sub __n($$$@); sub __nx($$$@); sub __xn($$$@);
33 sub N__($); sub N__n($$); sub N__w(@);
34
35 require Log::Report::Translator::POT;
36 my %translator =
37 ( 'log-report' => Log::Report::Translator::POT->new(charset => 'utf-8')
38 , rescue => Log::Report::Translator->new
39 );
40
41 my $reporter;
42 my %domain_start;
43
44 dispatcher FILE => stderr =>
45 to => \*STDERR, accept => 'NOTICE-'
46 if -t STDERR;
47
48 =chapter NAME
49 Log::Report - report a problem, pluggable handlers and language support
50
51 =chapter SYNOPSIS
52
53 # Read section "The Reason for the report" first!!!
54 # THIS IS THE FIRST RELEASE... please report problems!!! A few
55 # things do need to be improved, but all the basics are in already.
56
57 # In your main script
58
59 use Log::Report;
60
61 dispatcher FILE => 'stderr', to => \*STDERR
62 , reasons => 'NOTICE-'; # this disp. is automatically added
63
64 dispatcher SYSLOG => 'syslog'
65 , charset => 'iso-8859-1' # explicit conversions
66 , locale => 'en_US'; # overrule user's locale
67
68 # in all (other) files
69 use Log::Report 'my-domain';
70 report ERROR => __x('gettext string', param => $param, ...)
71 if $condition;
72
73 # overrule standard behavior for single message with HASH
74 use Errno qw/ENOMEM/;
75 report {to => 'syslog', errno => ENOMEM}
76 , FAULT => __x"cannot allocate {size} bytes", size => $size;
77
78 use Log::Report 'my-domain', syntax => 'SHORT';
79 error __x('gettext string', param => $param, ...)
80 if $condition;
81
82 # avoid messages without report level
83 print __"Hello World", "\n";
84
85 fault __x "cannot allocate {size} bytes", size => $size;
86 fault "cannot allocate $size bytes"; # no translation
87 fault __x "cannot allocate $size bytes"; # wrong, not static
88
89 print __xn("found one file", "found {_count} files", @files), "\n";
90
91 try { error };
92 if($@) {...}
93
94 =chapter DESCRIPTION
95 Handling messages to users can be a hassle, certainly when the same
96 module is used for command-line and in a graphical interfaces, and
97 has to cope with internationalization at the same time; this set of
98 modules tries to simplify this. Log::Report combines C<gettext> features
99 with M<Log::Dispatch>-like features. However, you can also use this
100 module to do only translations or only message dispatching.
101
102 Read more about how and why in the L</DETAILS> section, below. Especially,
103 you should B<read about the REASON parameter>.
104
105 Content of the whole C<Log::Report> package:
106
107 =over 4
108 =item . Log::Report
109 Exports the functions to end-users. To avoid the need to pass around
110 an logger-object to all end-user packages, the singleton object is
111 wrapped in functions.
112
113 =item . Translating
114 You can use the GNU gettext infrastructure (via MO files handled by
115 M<Log::Report::Translator::Gettext>), or extract strings via PPI
116 (M<Log::Report::Extract::PerlPPI>) into PO files which can be
117 used directly (M<Log::Report::Lexicon::POTcompact>).
118
119 =item . Dispatching
120 Multiple dispatchers in parallel can be active. M<Log::Report::Dispatcher>
121 takes care that the back-end gets the messages of the severity it needs,
122 translated and in the right character-set.
123
124 =back
125
126 =chapter FUNCTIONS
127
128 =section Report Production and Configuration
129
130 =function report [HASH-of-OPTIONS], REASON, MESSAGE [,more MESSAGE parts]
131
132 Produce a report for certain REASON. The MESSAGE is a LIST containing
133 strings and M<Log::Report::Message> objects (which are created with the
134 special translation syntax like M<__x()>). The HASH is an optional
135 first parameter, which can be used to influence the dispatchers. The
136 HASH contains any combination of the OPTIONS listed below.
137
138 When C<syntax => 'SHORT'> is configured, you will also have abbreviations
139 available, where the REASON is the name of the function. See for
140 instance M<info()>. In that case, you loose the chance for OPTIONS.
141
142 Returns is the LIST of dispatchers used to log the MESSAGE. When
143 empty, no back-end has accepted it so the MESSAGE was "lost". Even when
144 no back-end need the message, it program will still exit when there is
145 REASON to.
146
147 =option to NAME|ARRAY-of-NAMEs
148 =default to C<undef>
149 Sent the MESSAGE only to the NAMEd dispatchers. Ignore unknown NAMEs.
150 Still, the dispatcher needs to be enabled and accept the REASONs.
151
152 =option errno INTEGER
153 =default errno C<$!> or C<1>
154 When the REASON includes the error text (See L</Run modes>), you can
155 overrule the error code kept in C<$!>. In other cases, the return code
156 default to C<1> (historical UNIX behavior). When the message REASON
157 (combined with the run-mode) is severe enough to stop the program,
158 this value as return code. The use of this option itself will not
159 trigger an C<die()>.
160
161 =option stack ARRAY
162 =default stack C<undef>
163 When defined, that data is used to display the call stack. Otherwise,
164 it is collected via C<caller()> if needed.
165
166 =option location STRING
167 =default location C<undef>
168 When defined, this location is used in the display. Otherwise, it
169 is determined automatically if needed. An empty string will disable
170 any attempt to display this line.
171
172 =option locale LOCALE
173 =default locale C<undef>
174 Use this specific locale, in stead of the user's preference.
175
176 =examples for use of M<report()>
177 report TRACE => "start processing now";
178 report INFO => '500: ', __'Internal Server Error';
179
180 report {to => 'syslog'}, NOTICE => "started process $$";
181
182 # with syntax SHORT
183 trace "start processing now";
184 warning __x'Disk {percent%.2f}% full', percent => $p
185 if $p > 97;
186
187 # error message, overruled to be printed in Brazillian
188 report {locale => 'pt_BR'}
189 WARNING => __$!;
190
191 =cut
192
193 sub report($@)
194 { my $opts = ref $_[0] eq 'HASH' ? +{ %{ (shift) } } : {};
195 @_ or return ();
196
197 my $reason = shift;
198 $is_reason{$reason}
199 or error __"Token '{token}' not recognized as reason"
200 , token => $reason;
201
202 my @disp;
203 keys %{$reporter->{dispatchers}}
204 or return;
205
206 $opts->{errno} ||= $!+0 # want copy!
207 if $use_errno{$reason};
208
209 my $stop = $is_fatal{$reason};
210
211 # exit when needed, even when message doesn't go anywhere.
212 my $disp = $reporter->{needs}{$reason};
213 unless($disp)
214 { if($stop) { $! = $opts->{errno} || 1; die }
215 return ();
216 }
217
218 # explicit destination
219 if(my $to = delete $opts->{to})
220 { foreach my $t (ref $to eq 'ARRAY' ? @$to : $to)
221 { push @disp, grep {$_->name eq $t} @$disp;
222 }
223 }
224 else { @disp = @$disp }
225
226 # join does not respect overload of '.'
227 my $message = shift;
228 $message .= shift while @_;
229
230 # untranslated message into object
231 ref $message && $message->isa('Log::Report::Message')
232 or $message = Log::Report::Message->new(_prepend => $message);
233
234 if($reporter->{filters})
235 {
236 DISPATCHER:
237 foreach my $disp (@disp)
238 { my ($r, $m) = ($reason, $message);
239 foreach my $filter ( @{$reporter->{filters}} )
240 { next if keys %{$filter->[1]} && !$filter->[1]{$disp->name};
241 ($r, $m) = $filter->[0]->($disp, $opts, $r, $m);
242 $r or next DISPATCHER;
243 }
244 $disp->log($opts, $reason, $message);
245 }
246 }
247 else
248 { $_->log($opts, $reason, $message)
249 for @disp;
250 }
251
252 if($stop)
253 { $! = $opts->{errno} || 1;
254 die;
255 }
256
257 @disp;
258 }
259
260 =function dispatcher (TYPE, OPTIONS)|(COMMAND => NAME, [NAMEs])
261 The C<Log::Report> suite has its own dispatcher TYPES, but also connects
262 to external dispatching frame-works. Each need some (minor) conversions,
263 especially with respect to translation of REASONS of the reports
264 into log-levels as the back-end understands.
265
266 The OPTIONS are a mixture of parameters needed for the
267 Log::Report dispatcher wrapper and the settings of the back-end.
268 See M<Log::Report::Dispatcher>, the documentation for the back-end
269 specific wrappers, and the back-ends for more details.
270
271 Implemented COMMANDs are C<close>, C<find>, C<list>, C<disable>,
272 C<enable>, C<mode>, C<filter>, and C<needs>. Most commands are followed
273 by a LIST of dispatcher NAMEs to be address. For C<mode> see section
274 L</Run modes>; it requires a MODE argument before the LIST of NAMEs.
275 Non-existing names will be ignored. For C<filter> see
276 L<Log::Report::Dispatcher/Filters>; it requires a CODE reference before
277 the NAMEs of the dispatchers which will have the it applied (defaults to
278 all).
279
280 With C<needs>, you only provide a REASON: it will return the list of
281 dispatchers which need to be called in case of a message with the REASON
282 is triggered.
283
284 For both the creation as COMMANDs version of this method, all objects
285 involved are returned as LIST, non-existing ones skipped. In SCALAR
286 context with only one name, the one object is returned.
287
288 =examples play with dispatchers
289 dispatcher Log::Dispatcher::File => mylog =>
290 , accept => 'MISTAKE-' # for wrapper
291 , locale => 'pt_BR' # other language
292 , filename => 'logfile'; # for back-end
293
294 dispatcher close => 'mylog'; # cleanup
295 my $obj = dispatcher find => 'mylog';
296 my @obj = dispatcher list;
297 dispatcher disable => 'syslog';
298 dispatcher enable => 'mylog', 'syslog'; # more at a time
299 dispatcher mode => DEBUG => 'mylog';
300
301 my @need_info = dispatcher needs => 'INFO';
302 if(dispatcher needs => 'INFO') ...
303
304 # Getopt::Long integration: see Log::Report::Dispatcher::mode()
305 dispatcher FILE => stderr =>
306 to => \*STDERR, mode => 'DEBUG', accept => 'ALL'
307 if $debug;
308
309 =error in SCALAR context, only one dispatcher name accepted
310 The M<dispatcher()> method returns the M<Log::Report::Dispatcher>
311 objects which it has accessed. When multiple names where given, it
312 wishes to return a LIST of objects, not the count of them.
313 =cut
314
315 sub dispatcher($@)
316 { if($_[0] !~ m/^(?:close|find|list|disable|enable|mode|needs|filter)$/)
317 { my $disp = Log::Report::Dispatcher->new(@_);
318
319 # old dispatcher with same name will be closed in DESTROY
320 $reporter->{dispatchers}{$disp->name} = $disp;
321 _whats_needed;
322 return ($disp);
323 }
324
325 my $command = shift;
326 if($command eq 'list')
327 { mistake __"the 'list' sub-command doesn't expect additional parameters"
328 if @_;
329 return values %{$reporter->{dispatchers}};
330 }
331 if($command eq 'needs')
332 { my $reason = shift || 'undef';
333 error __"the 'needs' sub-command parameter '{reason}' is not a reason"
334 unless $is_reason{$reason};
335 my $disp = $reporter->{needs}{$reason};
336 return $disp ? @$disp : ();
337 }
338 if($command eq 'filter')
339 { my $code = shift;
340 error __"the 'filter' sub-command needs a CODE reference"
341 unless ref $code eq 'CODE';
342 my %names = map { ($_ => 1) } @_;
343 push @{$reporter->{filters}}, [ $code, \%names ];
344 return ();
345 }
346
347 my $mode = $command eq 'mode' ? shift : undef;
348
349 error __"in SCALAR context, only one dispatcher name accepted"
350 if @_ > 1 && !wantarray && defined wantarray;
351
352 my @dispatchers = grep defined, @{$reporter->{dispatchers}}{@_};
353 if($command eq 'close')
354 { delete @{$reporter->{dispatchers}}{@_};
355 $_->close for @dispatchers;
356 }
357 elsif($command eq 'enable') { $_->_disabled(0) for @dispatchers }
358 elsif($command eq 'disable') { $_->_disabled(1) for @dispatchers }
359 elsif($command eq 'mode'){ $_->_set_mode($mode) for @dispatchers }
360
361 # find does require reinventarization
362 _whats_needed unless $command eq 'find';
363
364 wantarray ? @dispatchers : $dispatchers[0];
365 }
366
367 END { $_->close for values %{$reporter->{dispatchers}} }
368
369 # _whats_needed
370 # Investigate from all dispatchers which reasons will need to be
371 # passed on. After dispatchers are added, enabled, or disabled,
372 # this method shall be called to re-investigate the back-ends.
373
374 sub _whats_needed()
375 { my %needs;
376 foreach my $disp (values %{$reporter->{dispatchers}})
377 { push @{$needs{$_}}, $disp for $disp->needs;
378 }
379 $reporter->{needs} = \%needs;
380 }
381
382 =function try CODE, OPTIONS
383 Execute the CODE, but block all dispatchers as long as it is
384 running. When the execution of the CODE is terminated with an
385 error, that is captured. After the C<try>, the C<$@> will contain a
386 M<Log::Report::Dispatcher::Try> object, which contains the collected
387 error messages.
388
389 The OPTIONS are passed to the constructor of the try-dispatcher, see
390 M<Log::Report::Dispatcher::Try::new(). For instance, you may like to
391 add C<< mode => 'DEBUG' >>, or C<< accept => 'ERROR-' >>.
392
393 Be warned that the parameter to C<try> is a CODE reference. This means
394 that you shall not use a comma after the block when there are OPTIONS
395 specified. On the other hand, you shall use a semi-colon after the
396 block if there are no arguments.
397 =examples
398 try { ... }; # mind the ';' !!
399 if($@) { # signals something went wrong
400
401 if(try {...}) { # block ended normally
402
403 try { ... } # no comma!!
404 mode => 'DEBUG', accept => 'ERROR-';
405
406 try sub { ... }, # with comma, also \&function
407 mode => 'DEBUG', accept => 'ALL';
408 =cut
409
410 sub try(&@)
411 { my $code = shift;
412 local $reporter->{dispatchers} = undef;
413 local $reporter->{needs};
414
415 my $disp = dispatcher TRY => 'try', @_;
416
417 eval { $code->() };
418 $disp->died($@);
419
420 $@ = $disp;
421 $disp->success;
422 }
423
424 =section Abbreviations for report()
425
426 The following functions are abbreviations for calls to M<report()>, and
427 available when syntax is C<SHORT> (see M<import()>). You cannot specify
428 additional options to influence the behavior of C<report()>, which are
429 usually not needed anyway.
430
431 =method trace MESSAGE
432 Short for C<< report TRACE => MESSAGE >>
433 =method assert MESSAGE
434 Short for C<< report ASSERT => MESSAGE >>
435 =method info MESSAGE
436 Short for C<< report INFO => MESSAGE >>
437 =method notice MESSAGE
438 Short for C<< report NOTICE => MESSAGE >>
439 =method warning MESSAGE
440 Short for C<< report WARNING => MESSAGE >>
441 =method mistake MESSAGE
442 Short for C<< report MISTAKE => MESSAGE >>
443 =method error MESSAGE
444 Short for C<< report ERROR => MESSAGE >>
445 =method fault MESSAGE
446 Short for C<< report FAULT => MESSAGE >>
447 =method alert MESSAGE
448 Short for C<< report ALERT => MESSAGE >>
449 =method failure MESSAGE
450 Short for C<< report FAILURE => MESSAGE >>
451 =method panic MESSAGE
452 Short for C<< report PANIc => MESSAGE >>
453 =cut
454
455 sub trace(@) {report TRACE => @_}
456 sub assert(@) {report ASSERT => @_}
457 sub info(@) {report INFO => @_}
458 sub notice(@) {report NOTICE => @_}
459 sub warning(@) {report WARNING => @_}
460 sub mistake(@) {report MISTAKE => @_}
461 sub error(@) {report ERROR => @_}
462 sub fault(@) {report FAULT => @_}
463 sub alert(@) {report ALERT => @_}
464 sub failure(@) {report FAILURE => @_}
465 sub panic(@) {report PANIC => @_}
466
467 =section Language Translations
468
469 =function __ MSGID
470 This function (name is two under-score characters) will cause the
471 MSGID to be replaced by the translations when doing the actual output.
472 Returned is one object, which will be used in translation later.
473 Translating is invoked when the object gets stringified.
474
475 If you need OPTIONS, then take M<__x()>.
476
477 =examples how to use __()
478 print __"Hello World"; # translated into user's language
479 print __'Hello World'; # syntax error!
480 print __('Hello World'); # ok, translated
481 print __"Hello", " World"; # World not translated
482
483 my $s = __"Hello World"; # creates object, not yet translated
484 print ref $s; # Log::Report::Message
485 print $s; # ok, translated
486 print $s->toString('fr'); # ok, forced into French
487 =cut
488
489 sub _default_domain(@)
490 { my $f = $domain_start{$_[1]} or return undef;
491 my $domain;
492 do { $domain = $_->[1] if $_->[0] < $_[2] } for @$f;
493 $domain;
494 }
495
496 sub __($)
497 { Log::Report::Message->new
498 ( _msgid => shift
499 , _domain => _default_domain(caller)
500 );
501 }
502
503 =function __x MSGID, OPTIONS, VARIABLES
504 Translate the MSGID, and then expand the VARIABLES in that
505 string. Of course, translation and expanding is delayed as long
506 as possible. Both OPTIONS and VARIABLES are key-value pairs.
507
508 OPTIONS and VARIABLES are explained in M<Log::Report::Message::new()>.
509 M<Locale::TextDomain::__x()> does not support the OPTIONS, but they
510 mix with variables.
511 =cut
512
513 # label "msgid" added before first argument
514 sub __x($@)
515 { Log::Report::Message->new
516 ( _msgid => @_
517 , _expand => 1
518 , _domain => _default_domain(caller)
519 );
520 }
521
522 =function __n MSGID, PLURAL_MSGID, COUNT, OPTIONS
523 It depends on the value of COUNT (and the selected language) which
524 text will be displayed. When translations can not be performed, then
525 MSGID will be used when COUNT is 1, and PLURAL_MSGSID in other cases.
526 However, some languages have more complex schemes than English.
527
528 OPTIONS are explained in M<Log::Report::Message::new()>.
529 M<Locale::TextDomain::__n()> does not have OPTIONS, but they mix
530 with variables.
531 =examples how to use __n()
532 print __n "one", "more", $a;
533 print __n("one", "more", $a), "\n";
534 print +(__n "one", "more", $a), "\n";
535 print __n "one\n", "more\n", $a;
536 =cut
537
538 sub __n($$$@)
539 { my ($single, $plural, $count) = (shift, shift, shift);
540 Log::Report::Message->new
541 ( _msgid => $single
542 , _plural => $plural
543 , _count => $count
544 , _domain => _default_domain(caller)
545 , @_
546 );
547 }
548
549 =function __nx MSGID, PLURAL_MSGID, COUNT, OPTIONS, VARIABLES
550 It depends on the value of COUNT (and the selected language) which
551 text will be displayed. See details in M<__n()>. After translation,
552 the VARIABLES will be filled-in.
553
554 OPTIONS are explained in M<Log::Report::Message::new()>.
555 M<Locale::TextDomain::__nx()> does not support the OPTIONS, but they look
556 like variables.
557 =examples how to use __nx()
558 print __nx "one file", "{_count} files", $nr_files;
559 print __nx "one file", "{_count} files", @files;
560
561 local $" = ', ';
562 print __nx "one file: {f}", "{_count} files: {f}", @files, f => \@files;
563 =cut
564
565 sub __nx($$$@)
566 { my ($single, $plural, $count) = (shift, shift, shift);
567 Log::Report::Message->new
568 ( _msgid => $single
569 , _plural => $plural
570 , _count => $count
571 , _expand => 1
572 , _domain => _default_domain(caller)
573 , @_
574 );
575 }
576
577 =function __xn SINGLE_MSGID, PLURAL_MSGID, COUNT, OPTIONS, VARIABLES
578 Same as M<__xn()>.
579 =cut
580
581 sub __xn($$$@) # repeated for prototype
582 { my ($single, $plural, $count) = (shift, shift, shift);
583 Log::Report::Message->new
584 ( _msgid => $single
585 , _plural => $plural
586 , _count => $count
587 , _expand => 1
588 , _domain => _default_domain(caller)
589 , @_
590 );
591 }
592
593 =function N__ MSGID
594 Label to indicate that the string is a text which will be translated
595 later. The function itself does nothing. See also M<N__w()>.
596
597 =example how to use N__()
598 my @colors = (N__"red", N__"green", N__"blue");
599 my @colors = N__w "red green blue"; # same
600 print __ $colors[1];
601
602 Using M<__()>, would work as well
603 my @colors = (__"red", __"green", __"blue");
604 print $colors[1];
605 However: this will always create all M<Log::Report::Message> objects,
606 where maybe only one is used.
607 =cut
608
609 sub N__($) {shift}
610
611 =function N__n SINGLE_MSGID, PLURAL_MSGID
612 Label to indicate that the two MSGIDs are related, the first as
613 single, the seconds as its plural. Only used to find the text
614 fragments to be translated. The function itself does nothing.
615 =examples how to use M<N__n()>
616 my @save = N__n "save file", "save files";
617 my @save = (N__n "save file", "save files");
618 my @save = N__n("save file", "save files");
619
620 # be warned about SCALARs in prototype!
621 print __n @save, $nr_files; # wrong!
622 print __n $save[0], $save[1], $nr_files;
623 =cut
624
625 sub N__n($$) {@_}
626
627 =function N__w STRING
628 This extension to the M<Locale::TextDomain> syntax, is a combined
629 C<qw> (list of quoted words) and M<N__()> into a list of translatable
630 words.
631
632 =example of M<N__w()>
633 my @colors = (N__"red", N__"green", N__"blue");
634 my @colors = N__w"red green blue"; # same
635 print __ $colors[1];
636 =cut
637
638 sub N__w(@) {split " ", $_[0]}
639
640 =section Configuration
641
642 =method import [DOMAIN], OPTIONS
643 The import is automatically called when the package is compiled. For all
644 packages but one in your distribution, it will only contain the name of
645 the DOMAIN. For one package, it will contain configuration information.
646 These OPTIONS are used for all packages which use the same DOMAIN.
647
648 =option syntax 'REPORT'|'SHORT'
649 =default syntax 'REPORT'
650 The SHORT syntax will add the report abbreviations (like function
651 M<error()>) to your name-space. Otherwise, each message must be produced
652 with M<report()>.
653
654 =option translator Log::Report::Translator
655 =default translator <rescue>
656 Without explicit translator, a dummy translator is used for the domain
657 which will use the untranslated message-id .
658
659 =examples of import
660 use Log::Report 'my-domain' # in each package
661 , syntax => 'SHORT';
662
663 use Log::Report 'my-domain' # in one package
664 , translator => Log::Report::Translator::POT->new
665 ( lexicon => '/home/me/locale' # bindtextdomain
666 , charset => 'UTF-8' # codeset
667 );
668
669 =cut
670
671 sub import(@)
672 { my $class = shift;
673
674 my $textdomain = @_%2 ? shift : undef;
675 my %opts = @_;
676 my $syntax = delete $opts{syntax} || 'REPORT';
677 my ($pkg, $fn, $linenr) = caller;
678
679 if(my $trans = delete $opts{translator})
680 { $class->translator($textdomain, $trans, $pkg, $fn, $linenr);
681 }
682
683 push @{$domain_start{$fn}}, [$linenr => $textdomain];
684
685 my @export = (@functions, @make_msg);
686 push @export, @reason_functions
687 if $syntax eq 'SHORT';
688
689 $class->export_to_level(1, undef, @export);
690 }
691
692 =c_method translator TEXTDOMAIN, [TRANSLATOR]
693 Returns the translator configured for the TEXTDOMAIN. By default,
694 a translator is configured which does not translate but directly
695 uses the gettext message-ids.
696
697 When a TRANSLATOR is specified, it will be set to be used for the
698 TEXTDOMAIN. When it is C<undef>, the configuration is removed.
699 You can only specify one TRANSLATOR per TEXTDOMAIN.
700
701 =examples use if M<translator()>
702 # in three steps
703 use Log::Report;
704 my $gettext = Log::Report::Translator::POT->new(...);
705 Log::Report->translator('my-domain', $gettext);
706
707 # in two steps
708 use Log::Report;
709 Log::Report->translator('my-domain'
710 , Log::Report::Translator::POT->new(...));
711
712 # in one step
713 use Log::Report 'my-domain'
714 , translator => Log::Report::Translator::POT->new(...);
715
716 =cut
717
718 sub translator($;$$$$)
719 { my ($class, $domain) = (shift, shift);
720
721 @_ or return $translator{$domain || 'rescue'} || $translator{rescue};
722
723 defined $domain
724 or error __"textdomain for translator not defined";
725
726 my ($translator, $pkg, $fn, $line) = @_;
727 ($pkg, $fn, $line) = caller # direct call, not via import
728 unless defined $pkg;
729
730 if(my $t = $translator{$domain})
731 { error __x"textdomain '{domain}' configured twice. First: {fn} line {nr}"
732 , domain => $domain, fn => $t->{filename}, nr => $t->{linenr};
733 }
734
735 $translator->isa('Log::Report::Translator')
736 or error __"translator must be a Log::Report::Translator object";
737
738 $translator{$domain} =
739 { translator => $translator
740 , package => $pkg, filename => $fn, linenr => $line
741 };
742
743 $translator;
744 }
745
746 =section Reasons
747
748 =ci_method isValidReason STRING
749 Returns true if the STRING is one of the predefined REASONS.
750
751 =ci_method isFatal REASON
752 Returns true if the REASON is severe enough to cause an exception
753 (or program termination).
754 =cut
755
756 sub isValidReason($) { $is_reason{$_[1]} }
757 sub isFatal($) { $is_fatal{$_[1]} }
758
759 =chapter DETAILS
760
761 =section Introduction
762
763 There are three steps in this story: produce some text on a certain
764 condition, translate it to the proper language, and deliver it in some
765 way to a user. Texts are usually produced by commands like C<print>,
766 C<die>, C<warn>, C<carp>, or C<croak>, which have no way of configuring
767 the way of delivery to the user. Therefore, they are replaced with a
768 single new command: C<report> (with various abbreviations)
769
770 Besides, the C<print>/C<warn>/C<die> together produce only three levels of
771 reasons to produce the message: many people manually implement more, like
772 verbose and debug. Syslog has some extra levels as well, like C<critical>.
773 The REASON argument to C<report()> replace them all.
774
775 The translations use the beautiful syntax defined by
776 M<Locale::TextDomain>, with some extensions (of course). The main
777 difference is that the actual translations are delayed till the delivery
778 step. This means that the popup in the graphical interface of the
779 user will show the text in the language of the user, say Chinese,
780 but at the same time syslog may write the English version of the text.
781 With a little luck, translations can be avoided.
782
783 =section Background ideas
784
785 The following ideas are the base of this implementation:
786
787 =over 4
788
789 =item . simplification
790 Handling errors and warnings is probably the most labour-intensive
791 task for a programmer: when programs are written correctly, up-to
792 three-quarters of the code is related to testing, reporting, and
793 handling (problem) conditions. Simplifying the way to create reports,
794 simplifies programming and maintenance.
795
796 =item . multiple dispatchers
797 It is not the location where the (for instance) error occurs determines
798 what will happen with the text, but the main application which uses the
799 the complaining module has control. Messages have a reason. Based
800 on the reason, they can get ignored, send to one, or send to multiple
801 dispatchers (like M<Log::Dispatch>, M<Log::Log4perl>, or UNIX syslog(1))
802
803 =item . delayed translations
804 The background ideas are that of M<Locale::TextDomain>, based
805 on C<gettext()>. However, the C<Log::Report> infrastructure has a
806 pluggable translation backend. Translations are postponed until the
807 text is dispatched to a user or log-file; the same report can be sent
808 to syslog in (for instance) English and to the user interface in Dutch.
809
810 =item . avoid dupplication
811 The same message may need to be documented on multiple locations: in
812 web-pages for the graphical interface, in pod for the command-line
813 configuration. The same text may even end-up in pdf user-manuals. When
814 the message is written inside the Perl code, it's quite hard to get it
815 out, to generate these documents. Only an abstract message discription
816 protocol will make flexible re-use possible.
817 This component still needs to be implemented.
818
819 =back
820
821 =section Error handling models
822
823 There are two approaches to handling errors and warnings. In the first
824 approach, as produced by C<die>, C<warn> and the C<carp> family of
825 commands, the program handles the problem immediately on the location
826 where the problem appears. In the second approach, an I<exception>
827 is thrown on the spot where the problem is created, and then somewhere
828 else in the program the condition is handled.
829
830 The implementation of exceptions in Perl5 is done with a eval-die pair:
831 on the spot where the problem occurs, C<die> is called. But, because of
832 the execution of that routine is placed within an C<eval>, the program
833 as a whole will not die, just the execution of a part of the program
834 will seize. However, what if the condition which caused the routine to die
835 is solvable on a higher level? Or what if the user of the code doesn't
836 bother that a part fails, because it has implemented alternatives for
837 that situation? Exception handling is quite clumpsy in Perl5.
838
839 The C<Log::Report> set of distributions let modules concentrate on the
840 program flow, and let the main program decide on the report handling
841 model. The infrastructure to translate messages into multiple languages,
842 whether to create exceptions or carp/die, to collect longer explanations
843 with the messages, to log to mail or syslog, and so on, is decided in
844 pluggable back-ends.
845
846 =subsection The Reason for the report
847
848 Traditionally, perl has a very simple view on error reports: you
849 either have a warning or an error. However, it would be much clearer
850 for user's and module-using applications, when a distinction is made
851 between various causes. For instance, a configuarion error is quite
852 different from a disk-full situation. In C<Log::Report>, the produced
853 reports in the code tell I<what> is wrong. The main application defines
854 loggers, which interpret the cause into (syslog) levels.
855
856 Defined by C<Log::Report> are
857
858 =over 4
859 =item . trace (debug, program)
860 The message will be used when some logger has debugging enabled. The
861 messages show steps taken by the program, which are of interest by the
862 developers and maintainers of the code, but not for end-users.
863
864 =item . assert (program)
865 Shows an unexpected condition, but continues to run. When you want the
866 program to abort in such situation, that use C<panic>.
867
868 =item . info (verbose, program)
869 These messages show larger steps in the execution of the program.
870 Experienced users of the program usually do not want to see all these
871 intermediate steps. Most programs will display info messages (and
872 higher) when some C<verbose> flag is given on the command-line.
873
874 =item . notice (program)
875 An user may need to be aware of the program's accidental smart behavior,
876 for instance, that it initializes a lasting C<Desktop> directory in your
877 home directory. Notices should be sparse.
878
879 =item . warning (program)
880 The program encountered some problems, but was able to work around it
881 by smart behavior. For instance, the program does not understand a
882 line from a log-file, but simply skips the line.
883
884 =item . mistake (user)
885 When a user does something wrong, but what is correctable by smart
886 behavior of the program. For instance, in some configuration file,
887 you can fill-in "yes" or "no", but the user wrote "yeh". The program
888 interprets this as "yes", producing a mistake message as warning.
889
890 It is much nicer to tell someone that he/she made a mistake, than
891 to call that an error.
892
893 =item . error (user)
894 The user did something wrong, which is not automatically correctable
895 or the program is not willing to correct it automatically for reasons
896 of code quality. For instance, an unknown option flag is given on the
897 command-line. These are configuration issues, and have no useful
898 value in C<$!>. The program will be stopped, usually before taken off.
899
900 =item . fault (system)
901 The program encountered a situation where it has no work-around. For
902 instance, a file cannot be opened to be written. The cause of that
903 problem can be some user error (i.e. wrong filename), or external
904 (you accidentally removed a directory yesterday). In any case, the
905 C<$!> (C<$ERRNO>) variable is set here.
906
907 =item . alert (system)
908 Some external cause disturbes the execution of the program, but the
909 program stays alive and will try to continue operation. For instance,
910 the connection to the database is lost. After a few attempts, the
911 database can be reached and the program continues as if nothing happend.
912 The cause is external, so C<$!> is set. Usually, a system administrator
913 needs to be informed about the problem.
914
915 =item . failure (system)
916 Some external cause makes it impossible for this program to continue.
917 C<$!> is set, and usually the system administrator wants to be
918 informed. The program will die.
919
920 =item . panic (program)
921 All above report classes are expected: some predicitable situation
922 is encountered, and therefore a message is produced. However, programs
923 often do some internal checking. Of course, these conditions should
924 never be triggered, but if they do... then we can only stop.
925
926 For instance, in an OO perl module, the base class requires all
927 sub-classes to implement a certain method. The base class will produce
928 a stub method with triggers a panic when called. The non-dieing version
929 of this test C<assert>.
930 =back
931
932 I<Debugging> or being C<verbose> are run-time behaviors, and have nothing
933 directly to do with the type of message which is produced. These two
934 are B<modes> which can be set on the dispatchers: one dispatcher may
935 be more verbose that some other.
936
937 On purpose, we do not use the terms C<die> or C<fatal>, because the
938 dispatcher can be configured what to do in cause of which condition.
939 For instance, it may decide to stop execution on warnings as well.
940
941 The terms C<carp> and C<croak> are avoided, because the program cause
942 versus user cause distinction (warn vs carp) is reflected in the use
943 of different reasons. There is no need for C<confess> and C<croak>
944 either, because the dispatcher can be configured to produce stack-trace
945 information (for a limited sub-set of dispatchers)
946
947 =subsection Report levels
948 Various frameworks used with perl programs define different labels
949 to indicate the reason for the message to be produced.
950
951 Perlish Log::Dispatch Log4Perl Log::Report
952 print 0,debug debug trace
953 print 0,debug debug assert
954 print 1,info info info
955 warn\n 2,notice info notice
956 warn 3,warning warn mistake
957 carp 3,warning warn warning
958 die\n 4,error,err error error
959 die 5,critical,crit fatal fault
960 croak 6,alert fatal alert
961 croak 7,emergency,emerg fatal failure
962 confess 7,emergency,emerg fatal panic
963
964 A typical perl5 program can look like this
965
966 my $dir = '/etc';
967
968 File::Spec->file_name is_absolute($dir)
969 or die "ERROR: directory name must be absolute.\n";
970
971 -d $dir
972 or die "ERROR: what platform are you on?";
973
974 until(opendir DIR, $dir)
975 { warn "ERROR: cannot read system directory $dir: $!";
976 sleep 60;
977 }
978
979 print "Processing directory $dir\n"
980 if $verbose;
981
982 while(defined(my $file = readdir DIR))
983 { if($file =~ m/\.bak$/)
984 { warn "WARNING: found backup file $dir/$f\n";
985 next;
986 }
987
988 die "ERROR: file $dir/$file is binary"
989 if $debug && -B "$dir/$file";
990
991 print "DEBUG: processing file $dir/$file\n"
992 if $debug;
993
994 open FILE, "<", "$dir/$file"
995 or die "ERROR: cannot read from $dir/$f: $!";
996
997 close FILE
998 or croak "ERROR: read errors in $dir/$file: $!";
999 }
1000
1001 Where C<die>, C<warn>, and C<print> are used for various tasks. With
1002 C<Log::Report>, you would write
1003
1004 use Log::Report syntax => 'SHORT';
1005 dispatcher stderr => 'FILE', mode => 'DEBUG', to => \*STDERR;
1006
1007 my $dir = '/etc';
1008
1009 File::Spec->file_name is_absolute($dir)
1010 or mistake "directory name must be absolute";
1011
1012 -d $dir
1013 or panic "what platform are you on?";
1014
1015 until(opendir DIR, $dir)
1016 { alert "cannot read system directory $dir";
1017 sleep 60;
1018 }
1019
1020 info "Processing directory $dir";
1021
1022 while(defined(my $file = readdir DIR))
1023 { if($file =~ m/\.bak$/)
1024 { notice "found backup file $dir/$f";
1025 next;
1026 }
1027
1028 assert "file $dir/$file is binary"
1029 if -B "$dir/$file";
1030
1031 trace "processing file $dir/$file";
1032
1033 unless(open FILE, "<", "$dir/$file")
1034 { error "no permission to read from $dir/$f"
1035 if $!==ENOPERM;
1036 fault "unable to read from $dir/$f";
1037 }
1038
1039 close FILE
1040 or failure "read errors in $dir/$file";
1041 }
1042
1043 A lot of things are quite visibly different, and there are a few smaller
1044 changes. There is no need for a new-line after the text of the message.
1045 When applicable (error about system problem), then the C<$!> is added
1046 automatically.
1047
1048 The distinction between C<error> and C<fault> is a bit artificial her, just
1049 to demonstrate the difference between the two. In this case, I want to
1050 express very explicitly that the user made an error by passing the name
1051 of a directory in which a file is not readible. In the common case,
1052 the user is not to blame and we can use C<fault>.
1053
1054 =subsection Run modes
1055 The run-mode change which messages are passed to a dispatcher, but
1056 from a different angle than the dispatch filters; the mode changes
1057 behavioral aspects of the messages, which are described in detail in
1058 L<Log::Report::Dispatcher/Processing the message>. However, it should
1059 behave as you expect: the DEBUG mode shows more than the VERBOSe mode,
1060 and both show more than the NORMAL mode.
1061
1062 =example extract run mode from Getopt::Long
1063 The C<GetOptions()> function will count the number of C<v> options
1064 on the command-line when a C<+> is after the option name.
1065
1066 use Log::Report syntax => 'SHORT';
1067 use Getopt::Long qw(:config no_ignore_case bundling);
1068
1069 my $mode; # defaults to NORMAL
1070 GetOptions 'v+' => \$mode
1071 , 'verbose=i' => \$mode
1072 , 'mode=s' => \$mode
1073 or exit 1;
1074
1075 dispatcher FILE => 'stderr', to => \*STDERR, mode => $mode;
1076
1077 Now, C<-vv> will set C<$mode> to C<2>, as will C<--verbose 2> and
1078 C<--verbose=2> and C<--mode=ASSERT>. Of course, you do not need to
1079 provide all these options to the user: make a choice.
1080
1081 =example the mode of a dispatcher
1082 my $mode = dispatcher(find => 'myname')->mode;
1083
1084 =example run-time change mode of a dispatcher
1085 To change the running mode of the dispatcher, you can do
1086 dispatcher mode => DEBUG => 'myname';
1087
1088 However, be warned that this does not change the types of messages
1089 accepted by the dispatcher! So: probably you will not receive
1090 the trace, assert, and info messages after all. So, probably you
1091 need to replace the dispatcher with a new one with the same name:
1092 dispatcher FILE => 'myname', to => ..., mode => 'DEBUG';
1093
1094 This may reopen connections (depends on the actual dispatcher), which
1095 might be not what you wish to happend. In that case, you must take
1096 the following approach:
1097
1098 # at the start of your program
1099 dispatcher FILE => 'myname', to => ...
1100 , accept => 'ALL'; # overrule the default 'NOTICE-' !!
1101
1102 # now it works
1103 dispatcher mode => DEBUG => 'myname'; # debugging on
1104 ...
1105 dispatcher mode => NORMAL => 'myname'; # debugging off
1106
1107 Of course, this comes with a small overall performance penalty.
1108
1109 =subsection Exceptions
1110
1111 The simple view on live says: you 're dead when you die. However,
1112 complexer situations try to revive the dead. Typically, the "die"
1113 is considered a terminating exception, but not terminating the whole
1114 program, but only some logical block. Of course, a wrapper round
1115 that block must decide what to do with these emerging problems.
1116
1117 Java-like languages do not "die" but throw exceptions which contain the
1118 information about what went wrong. Perl modules like M<Exception::Class>
1119 simulate this. It's a hassle to create exception class objects for each
1120 emerging problem, and the same amount of work to walk through all the
1121 options.
1122
1123 Log::Report follows a simpler scheme. Fatal messages will "die", which is
1124 caught with "eval", just the Perl way (used invisible to you). However,
1125 the wrapper get's its hands on the message as the user has specified it:
1126 untranslated, with all unprocessed parameters still at hand.
1127
1128 try { fault __x "cannot open file {file}", file => $fn };
1129 if($@) # is Log::Report::Dispatcher::Try
1130 { my $cause = $@->wasFatal; # is Log::Report::Exception
1131 $cause->throw if $cause->message->msgid =~ m/ open /;
1132 # all other problems ignored
1133 }
1134
1135 See M<Log::Report::Dispatcher::Try> and M<Log::Report::Exception>.
1136
1137 =section Comparison
1138
1139 =subsection Log::Dispatch and Log::Log4perl
1140 The two major logging frameworks for Perl are M<Log::Dispatch> and
1141 M<Log::Log4perl>; both provide a pluggable logging interface.
1142
1143 Both frameworks do not have (gettext or maketext) language translation
1144 support, which has various concequences. When you wish for to report
1145 in some other language, it must be translated before the logging
1146 function is called. This may mean that an error message is produced
1147 in Chinese, and therefore also ends-up in the syslog file in Chinese.
1148 When this is not your language, you have a problem.
1149
1150 Log::Report translates only in the back-end, which means that the user may
1151 get the message in Chinese, but you get your report in your beloved Dutch.
1152 When no dispatcher needs to report the message, then no time is lost in
1153 translating.
1154
1155 With both logging frameworks, you use terminology comparible to
1156 syslog: the module programmer determines the seriousness of the
1157 error message, not the application which integrates multiple modules.
1158 This is the way perl programs usually work, but often the cause for
1159 inconsequent user interaction.
1160
1161 =subsection Locale::gettext and Locate::TextDomain
1162 Both on GNU gettext based implementations can be used as translation
1163 frameworks. M<Locale::TextDomain> syntax is supported, with quite some
1164 extensions. Read the excellent documentation of Locale::Textdomain.
1165 Only the tried access via C<$__> and C<%__> are not supported.
1166
1167 The main difference with these modules is the moment when the translation
1168 takes place. In M<Locale::TextDomain>, an C<__x()> will result in an
1169 immediate translation request via C<gettext()>. C<Log::Report>'s version
1170 of C<__x()> will only capture what needs to be translated in an object.
1171 When the object is used in a print statement, only then the translation
1172 will take place. This is needed to offer ways to send different
1173 translations of the message to different destinations.
1174
1175 To be able to postpone translation, objects are returned which stringify
1176 into the translated text.
1177
1178 =cut
1179
1180 1;
+26
-0
t/00use.t less more
0 #!/usr/bin/perl
1 use warnings;
2 use strict;
3 use lib 'lib', '../lib';
4
5 use Test::More tests => 13;
6
7 use_ok('Log::Report');
8 use_ok('Log::Report::Dispatcher');
9 use_ok('Log::Report::Dispatcher::File');
10 use_ok('Log::Report::Dispatcher::Try');
11 use_ok('Log::Report::Exception');
12 use_ok('Log::Report::Lexicon::Index');
13 use_ok('Log::Report::Lexicon::PO');
14 use_ok('Log::Report::Lexicon::POT');
15 use_ok('Log::Report::Lexicon::POTcompact');
16 use_ok('Log::Report::Message');
17 use_ok('Log::Report::Translator');
18 use_ok('Log::Report::Translator::POT');
19 use_ok('Log::Report::Util');
20
21 # Log::Report::Extract::PerlPPI requires optional PPI
22 # Log::Report::Dispatcher::Syslog requires optional Sys::Syslog
23 # Log::Report::Dispatcher::LogDispatch requires optional Log::Dispatch
24 # Log::Report::Dispatcher::Log4perl requires optional Log::Log4perl
25 # Log::Report::Translator::Gettext requires optional Locale::gettext
+55
-0
t/05util.t less more
0 #!/usr/bin/perl
1 use warnings;
2 use strict;
3 use lib 'lib', '../lib';
4
5 use Test::More tests => 45;
6
7 use Log::Report;
8 use Log::Report::Util;
9
10 #
11 ## parse_locale
12 #
13
14 sub try_parse($@)
15 { my $locale = shift;
16 my @l = parse_locale $locale;
17 is($l[0], $_[0], $locale);
18 is($l[1], $_[1], ' ... territory');
19 is($l[2], $_[2], ' ... charset');
20 is($l[3], $_[3], ' ... modifier');
21 }
22
23 try_parse('nl', 'nl');
24 try_parse('');
25 try_parse('nl_NL', 'nl', 'NL');
26 try_parse('nl_NL.utf-8', 'nl', 'NL', 'utf-8');
27 try_parse('nl_NL.utf-8@mod', 'nl', 'NL', 'utf-8', 'mod');
28 try_parse('nl.utf-8');
29 try_parse('nl.utf-8@mod');
30 try_parse('nl_NL@mod', 'nl', 'NL', undef, 'mod');
31 try_parse('nl@mod', 'nl', undef, undef, 'mod');
32
33 #
34 ## expand_reasons
35 #
36
37 sub try_expand($$)
38 { my ($reasons, $expanded) = @_;
39 my @got = expand_reasons $reasons;
40 my $got = join ',', @got;
41 is($got, $expanded, $reasons);
42 }
43
44 my $all = join ',', @reasons;
45 try_expand('', '');
46 try_expand('TRACE', 'TRACE');
47 try_expand('PANIC,TRACE', 'TRACE,PANIC');
48 try_expand('USER', 'MISTAKE,ERROR');
49 try_expand('USER,PROGRAM,SYSTEM', $all);
50 try_expand('ALL', $all);
51 try_expand('WARNING-FAULT','WARNING,MISTAKE,ERROR,FAULT');
52 try_expand('-INFO','TRACE,ASSERT,INFO');
53 try_expand('ALERT-','ALERT,FAILURE,PANIC');
54
+134
-0
t/10interp.t less more
0 #!/usr/bin/perl
1 # Try __
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6
7 use Test::More tests => 63;
8
9 use Log::Report; # no domains, no translator
10 use Scalar::Util qw/reftype/;
11
12 ### examples from Log::Report::Message and more
13
14 my $a = __"Hello";
15 ok(defined $a);
16 is(ref $a, 'Log::Report::Message');
17 is(reftype $a, 'HASH');
18 is(__"Hello World", 'Hello World');
19 is(__"Hello World {a}", 'Hello World {a}');
20 is(__('Hello World {a}'), 'Hello World {a}');
21
22 my $c = __x"Hello";
23 ok(defined $c);
24 is(ref $c, 'Log::Report::Message');
25 is(reftype $c, 'HASH');
26 is(__x("Hello World", a => 42), 'Hello World');
27 is(__x("Hello World {a}", a => 42), 'Hello World 42');
28 is((__x"Hello World {a}", a => 42), 'Hello World 42');
29 is((__x "Hello World {a}", a => 42), 'Hello World 42');
30 is((__x "{a}{a}{a}", a => 42), '424242');
31
32 my $d = __n"Hello","World",3;
33 ok(defined $d);
34 is(ref $d, 'Log::Report::Message');
35 is(reftype $d, 'HASH');
36 is(__n("Hello", "World", 1), 'Hello');
37 is(__n("Hello", "World", 0), 'World');
38 is(__n("Hello", "World", 2), 'World');
39
40 my $e = __nx"Hello","World",3,a=>42;
41 ok(defined $e);
42 is(ref $e, 'Log::Report::Message');
43 is(reftype $e, 'HASH');
44 is(__nx("Hel{a}lo", "Wor{a}ld", 1,a=>42), 'Hel42lo');
45 is(__nx("Hel{a}lo", "Wor{a}ld", 0,a=>42), 'Wor42ld');
46 is(__nx("Hel{a}lo", "Wor{a}ld", 2,a=>42), 'Wor42ld');
47 is(__xn("Hel{a}lo", "Wor{a}ld", 2,a=>42), 'Wor42ld');
48
49 my $e1 = 1;
50 is((__nx "one", "more", $e1++), "one");
51 is((__nx "one", "more", $e1), "more");
52 my @files = 'monkey';
53 my $nr_files = @files;
54 is((__nx "one file", "{_count} files", $nr_files), 'one file');
55 is((__nx "one file", "{_count} files", @files), 'one file');
56 push @files, 'donkey';
57 $nr_files = @files;
58 is((__nx "one file", "{_count} files", $nr_files), '2 files');
59 is((__nx "one file", "{_count} files", @files), '2 files');
60
61 my $f = N__"Hi";
62 ok(defined $f);
63 is(ref $f, '');
64 is(N__"Hi", "Hi");
65 is((N__"Hi"), "Hi");
66 is(N__("Hi"), "Hi");
67
68 my @g = N__n "Hi", "bye";
69 cmp_ok(scalar @g, '==', 2);
70 is($g[0], 'Hi');
71 is($g[1], 'bye');
72
73 #
74 # Use _count directly
75 #
76
77 is(__nx("single {_count}", "multi {_count}", 0), 'multi 0');
78 is(__nx("single {_count}", "multi {_count}", 1), 'single 1');
79 is(__nx("single {_count}", "multi {_count}", 2), 'multi 2');
80
81 #
82 # Expand arrays
83 #
84 {
85 local $" = ', ';
86 my @one = 'rabbit';
87 is((__x "files: {f}", f => \@files), "files: monkey, donkey");
88 is((__xn "one file: {f}", "{_count} files: {f}", @files, f => \@files),
89 "2 files: monkey, donkey");
90 is((__x "files: {f}", f => \@one), "files: rabbit");
91 is((__xn "one file: {f}", "{_count} files: {f}", @one, f => \@one),
92 "one file: rabbit");
93 }
94
95 #
96 # clone
97 #
98
99 my $s2 = __x "found {nr} files", nr => 5;
100 my $t2 = $s2->(nr => 3);
101 isa_ok($t2, 'Log::Report::Message');
102 is($s2, 'found 5 files');
103 is($t2, 'found 3 files');
104
105 # clone by overload
106 my $s = __x "A={a};B={b}", a=>11, b=>12;
107 isa_ok($s, 'Log::Report::Message');
108 ok(reftype $s, 'HASH');
109 is($s->toString, "A=11;B=12");
110
111 my $t = $s->(b=>13);
112 isa_ok($t, 'Log::Report::Message');
113 ok(reftype $t, 'HASH');
114 isnt($s, $t);
115 is($t->toString, "A=11;B=13");
116 is($s->toString, "A=11;B=12"); # unchanged
117
118 #
119 # format
120 #
121
122 use constant PI => 4 * atan2(1, 1);
123 my $approx = 'approx pi: 3.141593';
124 is((sprintf "approx pi: %.6f", PI), $approx);
125 is((__x "approx pi: {approx}", approx => sprintf("%.6f", PI)), $approx);
126 is((__x "approx pi: {pi%.6f}", pi => PI), $approx);
127
128 is((__x "{perms} {links%2d} {user%-8s} {size%8d} {fn}"
129 , perms => '-rw-r--r--', links => 1, user => 'superman'
130 , size => '1234567', fn => '/etc/profile')
131 , '-rw-r--r-- 1 superman 1234567 /etc/profile');
132
133
+39
-0
t/11concat.t less more
0 #!/usr/bin/perl
1 # Try concatenation
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6
7 use Test::More tests => 15;
8
9 use Log::Report; # no domains, no translator
10 use Scalar::Util qw/refaddr/;
11
12 ### examples from Log::Report::Message and more
13
14 my $a = __"Hello";
15 isa_ok($a, 'Log::Report::Message');
16 my $b = $a . " World!\n";
17 isa_ok($b, 'Log::Report::Message');
18 cmp_ok(refaddr $a, '==', refaddr $b);
19 is("$b", "Hello World!\n");
20
21 my $c = 'a' . 'b' . __("c") . __("d") . "e" . __("f");
22 isa_ok($c, 'Log::Report::Message');
23 is("$c", "abcdef");
24 is($c->prepend, 'ab');
25 isa_ok($c->append, 'Log::Report::Message');
26 is($c->msgid, 'c');
27 is($c->untranslated, 'abcdef');
28
29 my $d = __("Hello")->concat(' ')->concat(__"World!")->concat("\n");
30 isa_ok($d, 'Log::Report::Message');
31 is("$d", "Hello World!\n");
32 is($d->untranslated, "Hello World!\n");
33
34 my $h = __"Hello";
35 my $w = __"World!";
36 my $e = "$h $w\n";
37 isa_ok($e, 'Log::Report::Message');
38 is("$e", "Hello World!\n");
+114
-0
t/20pot_read.t less more
0 #!/usr/bin/perl
1 # Try Lexicon POT
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6 use utf8;
7
8 use Test::More tests => 43;
9 use File::Basename qw/dirname/;
10 use File::Spec::Functions qw/catfile/;
11
12 use_ok('Log::Report::Lexicon::PO');
13 use_ok('Log::Report::Lexicon::POT');
14
15 my $sl_po = catfile(dirname(__FILE__), 'hello-world-slovak.po');
16
17 #
18 # Try reading complex example
19 # slightly modified from gettext examples in slovak
20 #
21
22 my $pot = Log::Report::Lexicon::POT->read($sl_po,
23 charset => 'utf-8');
24
25 ok(defined $pot, "read pot file");
26 isa_ok($pot, 'Log::Report::Lexicon::POT');
27
28 #
29 # header
30 #
31
32 is($pot->header('mime-version'), '1.0', 'access to header');
33
34 #
35 # plurals
36 #
37
38 cmp_ok($pot->nrPlurals, '==', 4, 'test plural evaluation');
39 cmp_ok($pot->pluralIndex(0), '==', 0);
40 cmp_ok($pot->pluralIndex(1), '==', 1);
41 cmp_ok($pot->pluralIndex(2), '==', 2);
42 cmp_ok($pot->pluralIndex(3), '==', 3);
43 cmp_ok($pot->pluralIndex(4), '==', 3);
44 cmp_ok($pot->pluralIndex(5), '==', 0);
45 cmp_ok($pot->pluralIndex(6), '==', 0);
46 cmp_ok($pot->pluralIndex(101), '==', 1);
47
48 #
49 # extended single case
50 #
51
52 my $po = $pot->msgid('Hello, world!');
53 ok(defined $po, "got greeting");
54 isa_ok($po, 'Log::Report::Lexicon::PO');
55 is($po->msgid, 'Hello, world!');
56 ok(!defined $po->plural);
57
58 is($po->comment, 'translator comment
59 translator comment line 2
60 ');
61
62 is($po->automatic, 'automatic comment
63 automatic comment line 2
64 ');
65
66 my @refs = sort $po->references;
67 cmp_ok(scalar @refs, '==', 4);
68 is($refs[0], 'bis');
69 is($refs[1], 'hello-1.pl.in:18');
70 is($refs[2], 'hello-1.pl.in:20');
71 is($refs[3], 'hello-2.pl.in:13');
72
73 is($po->msgstr, "Pozdravljen, svet!");
74 is($po->msgstr(0), "Pozdravljen, svet!");
75 ok(!defined $po->msgstr(1));
76
77 is($pot->msgstr("Hello, world!"), "Pozdravljen, svet!");
78 is($pot->msgstr("Hello, world!", 0), "Pozdravljen, svet!");
79
80 is($po->toString, <<'__DUMP');
81 # translator comment
82 # translator comment line 2
83 #. automatic comment
84 #. automatic comment line 2
85 #: bis hello-1.pl.in:18 hello-1.pl.in:20 hello-2.pl.in:13
86 msgid "Hello, world!"
87 msgstr "Pozdravljen, svet!"
88 __DUMP
89
90 #
91 # with plurals
92 #
93
94 is($pot->msgstr('Aap', 0), 'A', 'msgstr by plural');
95 is($pot->msgstr('Aap', 1), 'B');
96 is($pot->msgstr('Aap', 2), 'C');
97 is($pot->msgstr('Aap', 3), 'D');
98 is($pot->msgstr('Aap', 4), 'D');
99 is($pot->msgstr('Aap', 5), 'A');
100 is($pot->msgstr('Aap', 6), 'A');
101 is($pot->msgstr('Aap', 100), 'A');
102 is($pot->msgstr('Aap', 101), 'B');
103
104 is($pot->msgid('Aap')->plural, 'Apen');
105
106 #
107 # with multi-lines and utf
108 #
109
110 my $po2 = $pot->msgid("This program is running as process number {pid}.multi-line\n");
111 ok(defined $po2, 'test multi');
112 is($po2->msgstr, "Ta program teče kot proces številka {pid}.multi\tline\n");
113
+198
-0
t/21pot_modif.t less more
0 #!/usr/bin/perl
1 # Try Lexicon PO modifications
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6 use utf8;
7
8 use Test::More tests => 29;
9 use_ok('Log::Report::Lexicon::PO');
10 use_ok('Log::Report::Lexicon::POT');
11
12 #
13 # Create header
14 #
15
16 $Log::Report::VERSION = 'SOME_VERSION';
17 my $pot = Log::Report::Lexicon::POT->new
18 ( textdomain => 'log-report'
19 , version => '2.3'
20 , charset => 'UTF-8'
21 , date => 'DUMMY' # don't want this to change during test
22 );
23
24 is($pot->msgstr(''), <<'__HEADER');
25 Project-Id-Version: log-report 2.3
26 Report-Msgid-Bugs-To:
27 POT-Creation-Date: DUMMY
28 PO-Revision-Date: DUMMY
29 Last-Translator:
30 Language-Team:
31 MIME-Version: 1.0
32 Content-Type: text/plain; charset=UTF-8
33 Content-Transfer-Encoding: 8bit
34 Plural-Forms: nplurals=2; plural=(n!=1);
35 __HEADER
36
37 is($pot->msgid('')->toString, <<'__HEAD');
38 #. Header generated with Log::Report::Lexicon::POT SOME_VERSION
39 msgid ""
40 msgstr ""
41 "Project-Id-Version: log-report 2.3\n"
42 "Report-Msgid-Bugs-To:\n"
43 "POT-Creation-Date: DUMMY\n"
44 "PO-Revision-Date: DUMMY\n"
45 "Last-Translator:\n"
46 "Language-Team:\n"
47 "MIME-Version: 1.0\n"
48 "Content-Type: text/plain; charset=UTF-8\n"
49 "Content-Transfer-Encoding: 8bit\n"
50 "Plural-Forms: nplurals=2; plural=(n!=1);\n"
51 __HEAD
52
53 cmp_ok($pot->nrPlurals, "==", 2);
54
55 is($pot->header('mime-version'), '1.0');
56 is($pot->header('mime-version', '3.14'), '3.14');
57 is($pot->header('mime-version'), '3.14');
58 is($pot->header('mime-version', undef), undef);
59 is($pot->header('new-field', 'some value'), 'some value');
60
61 $pot->updated('NEWDATE');
62
63 is($pot->msgid('')->toString, <<'__HEAD');
64 #. Header generated with Log::Report::Lexicon::POT SOME_VERSION
65 msgid ""
66 msgstr ""
67 "Project-Id-Version: log-report 2.3\n"
68 "Report-Msgid-Bugs-To:\n"
69 "POT-Creation-Date: DUMMY\n"
70 "PO-Revision-Date: NEWDATE\n"
71 "Last-Translator:\n"
72 "Language-Team:\n"
73 "Content-Type: text/plain; charset=UTF-8\n"
74 "Content-Transfer-Encoding: 8bit\n"
75 "Plural-Forms: nplurals=2; plural=(n!=1);\n"
76 "new-field: some value\n"
77 __HEAD
78
79 #
80 # Create non-plural
81 #
82
83 my $po = Log::Report::Lexicon::PO->new
84 ( msgid => 'aap'
85 , references => 'aap.pm:10'
86 );
87
88 is($po->toString, <<'__AAP', 'no translation');
89 #: aap.pm:10
90 msgid "aap"
91 msgstr ""
92 __AAP
93
94 $po->addReferences('monkey.pm:12 aap.pm:3');
95 $po->msgstr(0, 'monkey');
96 is($po->toString, <<'__AAP', 'with translation');
97 #: aap.pm:10 aap.pm:3 monkey.pm:12
98 msgid "aap"
99 msgstr "monkey"
100 __AAP
101
102 is($po->plural("apen"), 'apen', 'add plural');
103 ok($po->fuzzy(1), 'is fuzzy');
104
105 is($po->toString, <<'__AAP');
106 #: aap.pm:10 aap.pm:3 monkey.pm:12
107 #, fuzzy
108 msgid "aap"
109 msgid_plural "apen"
110 msgstr[0] "monkey"
111 msgstr[1] ""
112 __AAP
113
114 is($po->toString(nr_plurals => $pot->nrPlurals), <<'__AAP');
115 #: aap.pm:10 aap.pm:3 monkey.pm:12
116 #, fuzzy
117 msgid "aap"
118 msgid_plural "apen"
119 msgstr[0] "monkey"
120 msgstr[1] ""
121 __AAP
122
123 $po->msgstr(1, 'monkeys');
124 $po->fuzzy(0);
125 cmp_ok($po->removeReferencesTo('aap.pm'), '==', 1);
126
127 is($po->toString(nr_plurals => $pot->nrPlurals), <<'__AAP');
128 #: monkey.pm:12
129 msgid "aap"
130 msgid_plural "apen"
131 msgstr[0] "monkey"
132 msgstr[1] "monkeys"
133 __AAP
134
135 #
136 # Index
137 #
138
139 ok(!$pot->msgid('aap'));
140 is($pot->add($po), $po, 'add');
141 is($pot->msgid('aap'), $po);
142
143 is($pot->msgstr('aap', 0), 'monkeys');
144 is($pot->msgstr('aap', 1), 'monkey');
145 is($pot->msgstr('aap', 2), 'monkeys');
146
147 #
148 # disable/enable
149 #
150
151 cmp_ok($po->removeReferencesTo('monkey.pm'), "==", 0, 'rm last ref');
152 is($po->toString(nr_plurals => $pot->nrPlurals), <<'__AAP');
153 #~ msgid "aap"
154 #~ msgid_plural "apen"
155 #~ msgstr[0] "monkey"
156 #~ msgstr[1] "monkeys"
157 __AAP
158
159 $po->addReferences('noot.pm:12', 'aap.pm:42');
160 is($po->toString(nr_plurals => $pot->nrPlurals), <<'__AAP');
161 #: aap.pm:42 noot.pm:12
162 msgid "aap"
163 msgid_plural "apen"
164 msgstr[0] "monkey"
165 msgstr[1] "monkeys"
166 __AAP
167
168 #
169 # Write
170 #
171
172 my $text = '';
173 open TEXT, '>:utf8', \$text;
174 $pot->write(\*TEXT);
175 close TEXT;
176
177 is($text, <<'__ALL')
178 #. Header generated with Log::Report::Lexicon::POT SOME_VERSION
179 msgid ""
180 msgstr ""
181 "Project-Id-Version: log-report 2.3\n"
182 "Report-Msgid-Bugs-To:\n"
183 "POT-Creation-Date: DUMMY\n"
184 "PO-Revision-Date: NEWDATE\n"
185 "Last-Translator:\n"
186 "Language-Team:\n"
187 "Content-Type: text/plain; charset=UTF-8\n"
188 "Content-Transfer-Encoding: 8bit\n"
189 "Plural-Forms: nplurals=2; plural=(n!=1);\n"
190 "new-field: some value\n"
191
192 #: aap.pm:42 noot.pm:12
193 msgid "aap"
194 msgid_plural "apen"
195 msgstr[0] "monkey"
196 msgstr[1] "monkeys"
197 __ALL
+71
-0
t/22compact.t less more
0 #!/usr/bin/perl
1 # Try Lexicon POTcompact
2 # Structure of parsed result has also been checked manually, using
3 # Data::Dumper (MO 2007/05/11)
4
5 use warnings;
6 use strict;
7 use lib 'lib', '../lib';
8 use utf8;
9
10 use Test::More tests => 21;
11
12 use File::Basename qw/dirname/;
13 use File::Spec::Functions qw/catfile/;
14
15 use_ok('Log::Report::Lexicon::POTcompact');
16
17 my $sl_po = catfile(dirname(__FILE__), 'hello-world-slovak.po');
18
19 #
20 # Try reading complex example
21 # slightly modified from gettext examples in slovak
22 #
23
24 my $pot = Log::Report::Lexicon::POTcompact->read($sl_po,
25 charset => 'utf-8');
26
27 ok(defined $pot, "read pot file");
28 isa_ok($pot, 'Log::Report::Lexicon::POTcompact');
29
30 #
31 # header
32 #
33
34 is($pot->header('mime-version'), '1.0', 'access to header');
35
36 #
37 # extended single case
38 #
39
40 my $po = $pot->msgid('Hello, world!');
41 ok(defined $po, "got greeting");
42 ok(!ref $po, "one translation only");
43 is($po, "Pozdravljen, svet!");
44
45 is($pot->msgstr("Hello, world!"), "Pozdravljen, svet!");
46 is($pot->msgstr("Hello, world!", 0), "Pozdravljen, svet!");
47 is($pot->msgstr("Hello, world!", 5), "Pozdravljen, svet!");
48
49 #
50 # with plurals
51 #
52
53 is($pot->msgstr('Aap', 0), 'A', 'msgstr by plural');
54 is($pot->msgstr('Aap', 1), 'B');
55 is($pot->msgstr('Aap', 2), 'C');
56 is($pot->msgstr('Aap', 3), 'D');
57 is($pot->msgstr('Aap', 4), 'D');
58 is($pot->msgstr('Aap', 5), 'A');
59 is($pot->msgstr('Aap', 6), 'A');
60 is($pot->msgstr('Aap', 100), 'A');
61 is($pot->msgstr('Aap', 101), 'B');
62
63 #
64 # with multi-lines and utf
65 #
66
67 my $po2 = $pot->msgid("This program is running as process number {pid}.multi-line\n");
68 ok(defined $po2, 'test multi');
69 is($po2, "Ta program teče kot proces številka {pid}.multi\tline\n");
70
+55
-0
t/30index.t less more
0 #!/usr/bin/perl
1 # test the lexicon index.
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6
7 use Test::More;
8
9 my $mailman_po;
10 my $not_exist = 'does-not-exist';
11
12 BEGIN
13 { $mailman_po = '/usr/lib/mailman/messages';
14 unless(-d $mailman_po)
15 { plan skip_all => 'cannot find sample translations, no problem';
16 exit 0;
17 }
18 plan tests => 12;
19 }
20
21 use Log::Report;
22 use_ok('Log::Report::Lexicon::Index');
23
24 #
25 # Directory does not exist
26 #
27
28 my $t = Log::Report::Lexicon::Index->new($not_exist);
29 ok(defined $t, 'create useless index');
30 isa_ok($t, 'Log::Report::Lexicon::Index');
31 ok(!defined $t->find('domain', 'locale'));
32
33 #
34 # Now it does exist
35 #
36
37 my $v = Log::Report::Lexicon::Index->new($mailman_po);
38 ok(defined $v, 'create mailman index');
39 isa_ok($v, 'Log::Report::Lexicon::Index');
40 ok(defined $v->index);
41 is($v->find('mailman', 'nl_NL.utf-8@test'), $mailman_po.'/nl/LC_MESSAGES/mailman.po');
42 is($v->find('mailman', 'pt_BR'), $mailman_po.'/pt_BR/LC_MESSAGES/mailman.po');
43 ok(!defined $v->find('mailman', 'xx_XX.ISO-8859-1@modif'));
44
45 #use Data::Dumper;
46 #warn Dumper $v;
47
48 #
49 # list textdomain files
50 #
51
52 my @l = $v->list('mailman');
53 ok(@l+0, 'list');
54 cmp_ok(scalar(@l), '>', 30); # I have 58, on the moment
+30
-0
t/31stack.t less more
0 #!/usr/bin/perl
1 # test the lexicon index.
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6
7 use Test::More tests => 1;
8
9 use Log::Report;
10 use Log::Report::Dispatcher;
11
12 my $stack;
13
14 my $start = __LINE__;
15 sub hhh(@) { $stack = Log::Report::Dispatcher->collectStack(3) }
16 sub ggg(@) { shift; hhh(@_) }
17 sub fff(@) { ggg(reverse @_) }
18
19 fff(42, 3.2, "this is a text");
20
21 #use Data::Dumper;
22 #warn Dumper $stack;
23
24 is_deeply($stack,
25 [ [ 'main::hhh(3.2, 42)', $0, $start+2 ]
26 , [ 'main::ggg("this is a text", 3.2, 42)', $0, $start+3 ]
27 , [ 'main::fff(42, 3.2, "this is a text")', $0, $start+5 ]
28 ]
29 );
+107
-0
t/40ppi.t less more
0 #!/usr/bin/perl
1 # Try Extract PPI
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6
7 use File::Temp qw/tempdir/;
8 use Test::More;
9
10 use constant MSGIDS => 24;
11 use constant PLURAL_MSGIDS => 4;
12 BEGIN
13 { eval "require PPI";
14 plan skip_all => 'PPI not installed'
15 if $@;
16
17 plan tests => 34 + MSGIDS*3 + PLURAL_MSGIDS*1;
18 use_ok('Log::Report::Extract::PerlPPI');
19 }
20
21 my $lexicon = tempdir; # CLEANUP => 1;
22
23 my %expect_pos = ('' => 1); # expect header
24 sub take($@)
25 { my $result = shift;
26 ok("$result", "$result");
27 $expect_pos{$_}++ for @_;
28 }
29
30 ###
31
32 my $ppi = Log::Report::Extract::PerlPPI->new
33 ( lexicon => $lexicon
34 );
35
36 ok(defined $ppi, 'created parser');
37 isa_ok($ppi, 'Log::Report::Extract::PerlPPI');
38
39 $ppi->process( __FILE__ ); # yes, this file!
40 $ppi->write;
41
42 my @potfns = $ppi->index->list('first-domain');
43 cmp_ok(scalar @potfns, '==', 1, "one file created");
44 my $potfn = shift @potfns;
45 ok(defined $potfn);
46 ok(-s $potfn, "produced file $potfn has size");
47
48 ####
49
50 sub dummy($) {shift}
51
52 use Log::Report 'first-domain'; # cannot use variable textdomain
53 take("a0");
54 take(__"a1", 'a1');
55 take((__"a2"), 'a2');
56 take((__"a3a", "a3b"), 'a3a');
57 take(__("a4"), 'a4');
58 take(__ dummy('a7'));
59 take(__ dummy 'a8');
60 take(__(dummy 'a9'));
61
62 take((__x"b2"), 'b2');
63 take((__x"b3a", b2b => "b3c"), 'b3a');
64 take(__x("b4"), 'b4');
65 take(__x("b5a", b5b => "b5c"), 'b5a');
66 take(__x('b6a', b6b => "b6c"), 'b6a');
67 take(__x(qq{b7a}, b7b => "b7c"), 'b7a');
68 take(__x(q{b8a}, b8b => "b8c"), 'b8a');
69 take(__x(b9a => b9b => "b9c"), 'b9a');
70
71 take((__n "c1", "c2", 1), "c1", "c2");
72 take((__n "c3", "c4", 0), "c3", "c4");
73 take(__n("c5", "c6", 1), "c5", "c6");
74 take(__n("c7", "c8", 0), "c7", "c8");
75
76 take(N__("d1"), "d1", "d1");
77
78 take(join(',', N__w("d2 d3")), "d2", "d3");
79 take(join(',', N__w(" d4 d5
80 d6
81 d7")), "d4", "d5", "d6", "d7"); # line contains tab
82
83 ### check that all tags were found in POT
84
85 my $pot = Log::Report::Lexicon::POT->read($potfn, charset => 'utf-8');
86 ok(defined $pot, 'read translation table');
87 my @pos = $pot->translations('ACTIVE');
88 ok(@pos > 0);
89 cmp_ok(scalar @pos, '==', MSGIDS, 'correct number tests');
90 cmp_ok(scalar @pos, '==', scalar $pot->translations); # all active
91
92 my %msgids;
93 for my $po (@pos)
94 { my $msgid = $po->msgid;
95 ok(defined $msgid, "processing $msgid");
96 ok(!defined $msgids{$msgid}, 'check not double');
97 $msgids{$msgid}++;
98 ok(delete $expect_pos{$msgid}, 'was expected');
99
100 my $plural = $po->plural
101 or next;
102 ok(delete $expect_pos{$plural}, 'plural was expected');
103 }
104
105 cmp_ok(scalar keys %expect_pos, '==', 0, "all msgids found");
106 warn "NOT FOUND: $_\n" for keys %expect_pos;
+116
-0
t/50file.t less more
0 #!/usr/bin/perl
1 # test the file back-end, without translations
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6
7 use Test::More tests => 38;
8
9 use Log::Report undef, syntax => 'SHORT';
10
11 my $disp_stderr = -t STDERR ? 1 : 0;
12
13 my @disp = dispatcher 'list';
14 cmp_ok(scalar(@disp), '==', $disp_stderr);
15
16 isa_ok($disp[0], 'Log::Report::Dispatcher');
17
18 # start new dispatcher to file
19
20 my $file1 = '';
21 open my($fh1), ">", \$file1 or die $!;
22 my $d = dispatcher FILE => 'file1'
23 , to => $fh1;
24
25 @disp = dispatcher 'list';
26 cmp_ok(scalar(@disp), '==', 1 + $disp_stderr);
27
28 ok(defined $d, 'created file dispatcher');
29 isa_ok($d, 'Log::Report::Dispatcher::File');
30 cmp_ok($d, '==', $disp[0]);
31 ok(!$d->isDisabled);
32 is($d->name, 'file1');
33
34 my @needs = $d->needs;
35 cmp_ok(scalar(@needs), '>', 7, 'needs');
36 is($needs[0], 'NOTICE');
37 is($needs[-1], 'PANIC');
38
39 # start a second dispatcher to a file, which does accept everything
40 # trace-info.
41
42 my $file2 = '';
43 open my($fh2), ">", \$file2 or die $!;
44 my $e = dispatcher FILE => 'file2'
45 , to => $fh2, accept => '-INFO';
46 ok(defined $e, 'created second disp');
47 isa_ok($e, 'Log::Report::Dispatcher::File');
48
49 @disp = dispatcher 'list';
50 cmp_ok(scalar(@disp), '==', 2 + $disp_stderr);
51
52 @needs = $e->needs;
53 cmp_ok(scalar(@needs), '>=', 3, 'needs');
54 is($needs[0], 'TRACE');
55 is($needs[-1], 'INFO');
56
57 # silence default dispatcher for tests
58
59 dispatcher close => 'stderr';
60
61 @disp = dispatcher 'list';
62 cmp_ok(scalar(@disp), '==', 2);
63
64 #
65 # Start producing messages
66 #
67
68 cmp_ok(length $file1, '==', 0);
69 cmp_ok(length $file2, '==', 0);
70
71 trace "trace";
72 cmp_ok(length $file1, '==', 0, 'disp1 ignores trace');
73 my $t = length $file2;
74 cmp_ok($t, '>', 0, 'disp2 take trace');
75 is($file2, "TRACE: trace\n");
76
77 my $linenr = __LINE__ +1;
78 assert "assertive";
79 cmp_ok(length $file1, '==', 0, 'disp1 ignores assert');
80 my $t2 = length $file2;
81 cmp_ok($t2, '>', $t, 'disp2 take assert');
82 is(substr($file2, $t), "ASSERT: assertive\n at $0 line $linenr\n");
83
84 info "just to inform you";
85 cmp_ok(length $file1, '==', 0, 'disp1 ignores info');
86 my $t3 = length $file2;
87 cmp_ok($t3, '>', $t2, 'disp2 take info');
88 is(substr($file2, $t2), "INFO: just to inform you\n");
89
90 notice "note this!";
91 my $s = length $file1;
92 cmp_ok($s, '>', 0, 'disp1 take notice');
93 is($file1, "NOTICE: note this!\n");
94 my $t4 = length $file2;
95 cmp_ok($t4, '==', $t3, 'disp2 ignores notice');
96
97 warning "oops, be warned!";
98 my $s2 = length $file1;
99 cmp_ok($s2, '>', $s, 'disp1 take warning');
100 like(substr($file1, $s), qr/^WARNING: oops, be warned!/);
101 my $t5 = length $file2;
102 cmp_ok($t5, '==', $t4, 'disp2 ignores warnings');
103
104 #
105 # test filters
106 #
107
108 my (@messages, @messages2);
109 dispatcher filter => sub { push @messages, $_[3] }, 'file1';
110 dispatcher filter => sub { push @messages2, $_[3] }, 'file2';
111
112 notice "here we are";
113 cmp_ok(scalar(@messages), '==', 1, 'capture message');
114 is($messages[0], 'here we are');
115 cmp_ok(scalar(@messages2), '==', 0, 'do not capture message');
+28
-0
t/51syslog.t less more
0 #!/usr/bin/perl
1 # Test syslog, but only mildly
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6
7 use File::Temp qw/tempdir/;
8 use Test::More;
9
10 use Log::Report undef, syntax => 'SHORT';
11
12 BEGIN
13 { eval "require Sys::Syslog";
14 plan skip_all => 'Sys::Syslog not installed'
15 if $@;
16
17 my $sv = Sys::Syslog->VERSION;
18 plan skip_all => "Sys::Syslog too old (is $sv, requires 0.11)"
19 if $sv < 0.11;
20
21 plan tests => 1;
22 use_ok('Log::Report::Dispatcher::Syslog');
23 }
24
25 dispatcher SYSLOG => 'syslog', to_prio => ['ALERT-' => 'err'];
26 dispatcher close => 'stderr';
27 notice "this is a test";
+45
-0
t/52logdisp.t less more
0 #!/usr/bin/perl
1 # Test Log::Dispatch (only very simple tests)
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6
7 use File::Temp qw/tempfile/;
8 use Test::More;
9
10 use Log::Report undef, syntax => 'SHORT';
11
12 BEGIN
13 { eval "require Log::Dispatch";
14 plan skip_all => 'Log::Dispatch not installed'
15 if $@;
16
17 my $sv = Log::Dispatch->VERSION;
18 plan skip_all => "Log::Dispatch too old (is $sv, requires 2.00)"
19 if $sv < 2.00;
20
21 plan tests => 5;
22 use_ok('Log::Report::Dispatcher::LogDispatch');
23 }
24
25 use_ok('Log::Dispatch::File');
26
27 my ($out, $outfn) = tempfile;
28 dispatcher 'Log::Dispatch::File' => 'logger'
29 , filename => $outfn
30 , to_level => ['ALERT-' => 'err'];
31
32 dispatcher close => 'stderr';
33
34 cmp_ok(-s $outfn, '==', 0);
35 notice "this is a test";
36 my $s1 = -s $outfn;
37 cmp_ok($s1, '>', 0);
38
39 warning "some more";
40 my $s2 = -s $outfn;
41 cmp_ok($s2, '>', $s1);
42
43 unlink $outfn;
44
+51
-0
t/53log4perl.t less more
0 #!/usr/bin/perl
1 # Test Log::Log4perl (only very simple tests)
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6
7 use File::Temp qw/tempfile/;
8 use Test::More;
9
10 use Log::Report undef, syntax => 'SHORT';
11
12 BEGIN
13 { eval "require Log::Log4perl";
14 plan skip_all => 'Log::Log4perl not installed'
15 if $@;
16
17 my $sv = Log::Log4perl->VERSION;
18 plan skip_all => "Log::Log4perl too old (is $sv, requires 1.00)"
19 if $sv < 1.00;
20
21 plan tests => 3;
22 }
23
24 my ($out, $outfn) = tempfile;
25 my $name = 'logger';
26
27 # adapted from the docs
28 my $conf = <<__CONFIG;
29 log4perl.category.$name = INFO, Logfile
30 log4perl.appender.Logfile = Log::Log4perl::Appender::File
31 log4perl.appender.Logfile.filename = $outfn
32 log4perl.appender.Logfile.layout = Log::Log4perl::Layout::PatternLayout
33 log4perl.appender.Logfile.layout.ConversionPattern = %d %F{1} %L> %m
34 __CONFIG
35
36 dispatcher 'Log::Log4perl' => $name, config => \$conf
37 , to_level => ['ALERT-' => 3];
38
39 dispatcher close => 'stderr';
40
41 cmp_ok(-s $outfn, '==', 0);
42 notice "this is a test";
43 my $s1 = -s $outfn;
44 cmp_ok($s1, '>', 0);
45
46 warning "some more";
47 my $s2 = -s $outfn;
48 cmp_ok($s2, '>', $s1);
49
50 unlink $outfn;
+78
-0
t/54try.t less more
0 #!/usr/bin/perl
1 # Test try()
2
3 use warnings;
4 use strict;
5 use lib 'lib', '../lib';
6
7 use File::Temp qw/tempfile/;
8 use Test::More tests => 23;
9
10 use Log::Report undef, syntax => 'SHORT';
11
12 # start a new logger
13 my $text = '';
14 open my($fh), '>', \$text;
15
16 dispatcher close => 'stderr';
17 dispatcher FILE => 'out', to => $fh, accept => 'ALL';
18
19 cmp_ok(length $text, '==', 0, 'created normal file logger');
20
21 my $text_l1 = length $text;
22 info "test";
23 my $text_l2 = length $text;
24 cmp_ok($text_l2, '>', $text_l1);
25
26 my @l1 = dispatcher 'list';
27 cmp_ok(scalar(@l1), '==', 1);
28 is($l1[0]->name, 'out');
29 try { my @l2 = dispatcher 'list';
30 cmp_ok(scalar(@l2), '==', 1);
31 is($l2[0]->name, 'try', 'only try dispatcher');
32 error __"this is an error"
33 };
34 my $caught = $@; # be careful with this... Test::More may spoil it.
35 my @l3 = dispatcher 'list';
36 cmp_ok(scalar(@l3), '==', 1);
37 is($l3[0]->name, 'out', 'original dispatcher restored');
38
39 isa_ok($caught, 'Log::Report::Dispatcher::Try');
40 ok($caught->failed);
41 ok($caught ? 1 : 0);
42 my @r1 = $caught->exceptions;
43 cmp_ok(scalar(@r1), '==', 1);
44 isa_ok($r1[0], 'Log::Report::Exception');
45 my @r2 = $caught->wasFatal;
46 cmp_ok(scalar(@r2), '==', 1);
47 isa_ok($r2[0], 'Log::Report::Exception');
48
49 try { info "nothing wrong";
50 trace "trace more"
51 } # no comma!
52 mode => 'DEBUG';
53
54 $caught = $@;
55 isa_ok($caught, 'Log::Report::Dispatcher::Try');
56 ok($caught->success);
57 ok($caught ? 0 : 1);
58 my @r3 = $caught->wasFatal;
59 cmp_ok(scalar(@r3), '==', 0);
60 my @r4 = $caught->exceptions;
61 cmp_ok(scalar(@r4), '==', 2);
62
63 $caught->reportAll; # pass on errors
64 my $text_l3 = length $text;
65 cmp_ok($text_l3, '>', $text_l2, 'passed on loggings');
66 is(substr($text, $text_l2), <<__EXTRA);
67 INFO: nothing wrong
68 TRACE: trace more
69 __EXTRA
70
71 eval {
72 try { try { failure "oops! no network" };
73 $@->reportAll;
74 };
75 $@->reportAll;
76 };
77 is($@, "FAILURE: oops! no network\n");
+50
-0
t/hello-world-slovak.po less more
0 # -*- mode: po; coding: utf-8; -*- Slovenian message catalog for GNU gettext-example
1 # Copyright (C) 2005 Yoyodyne, Inc.
2 # Primož Peterlin <primoz.peterlin@biofiz.mf.uni-lj.si>, 2005.
3 # $Id: sl.po,v 1.2 2006/04/20 14:10:34 haible Exp $
4 msgid ""
5 msgstr ""
6 "Project-Id-Version: hello-perl 0.14.5\n"
7 "Report-Msgid-Bugs-To: bug-gnu-gettext@gnu.org\n"
8 "POT-Creation-Date: 2007-04-18 15:27+0200\n"
9 "PO-Revision-Date: 2005-09-29 13:38+0200\n"
10 "Last-Translator: Primož Peterlin <primoz.peterlin@biofiz.mf.uni-lj.si>\n"
11 "Language-Team: Slovenian <translation-team-sl@lists.sourceforge.net>\n"
12 "MIME-Version: 1.0\n"
13 "Content-Type: text/plain; charset=UTF-8\n"
14 "Content-Transfer-Encoding: 8bit\n"
15 "Plural-Forms: nplurals=4; plural=(n%100==1 ? 1 : n%100==2 ? 2 : n%100==3 || n"
16 "%100==4 ? 3 : 0);\n"
17
18 # translator comment
19 # translator comment line 2
20 #. automatic comment
21 #. automatic comment line 2
22 #: hello-1.pl.in:20
23 #: hello-1.pl.in:18 hello-2.pl.in:13
24 #: hello-1.pl.in:20 bis
25 msgid "Hello, world!"
26 msgstr "Pozdravljen, svet!"
27
28 #: hello-1.pl.in:20
29 #, perl-format
30 msgid "This program is running as process number %d."
31 msgstr "Ta program teče kot proces številka %d."
32
33 #: hello-2.pl.in:16
34 #, perl-brace-format
35 msgid "This program is running as process number {pid}."
36 "multi-line\n"
37 msgstr "Ta program teče kot proces številka {pid}."
38 "multi\tline\n"
39
40 #: hello-2.pl.in:17
41 msgid "Aap"
42 msgid_plural "Apen"
43 msgstr[0] "A"
44 msgstr[1] "B"
45 msgstr[2] "C"
46 msgstr[3] "D"
47
48
49