File Coverage

blib/lib/Log/Report/Lexicon/POT.pm

Criterion	Covered	Total	%
statement	146	163	89.5
branch	48	84	57.1
condition	17	39	43.5
subroutine	26	29	89.6
pod	15	16	93.7
total	252	331	76.1

# This code is part of Perl distribution Log-Report-Lexicon version 1.15.
# The POD got stripped from this file by OODoc version 3.05.
# For contributors see file ChangeLog.

# This software is copyright (c) 2007-2025 by Mark Overmeer.

# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later

#oodist: *** DO NOT USE THIS VERSION FOR PRODUCTION ***
#oodist: This file contains OODoc-style documentation which will get stripped
#oodist: during its release in the distribution.  You can use this file for
#oodist: testing, however the code of this development version may be broken!
#oorestyle: old style disclaimer to be removed.
#oorestyle: not found P for method filename($filename)

# This code is part of distribution Log-Report-Lexicon. Meta-POD processed
# with OODoc into POD and HTML manual-pages.  See README.md
# Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.

package Log::Report::Lexicon::POT;{
our $VERSION = '1.15';
}

use base 'Log::Report::Lexicon::Table';

use warnings;
use strict;

use Log::Report 'log-report-lexicon';
use Log::Report::Lexicon::PO  ();

use POSIX        qw/strftime/;
use List::Util   qw/sum/;
use Scalar::Util qw/blessed/;
use Encode       qw/decode/;

use constant     MSGID_HEADER => '';

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

sub init($)
{	my ($self, $args) = @_;

	$self->{LRLP_fn}      = $args->{filename};
	$self->{LRLP_index}   = $args->{index}   || {};
	$self->{LRLP_charset} = $args->{charset} || 'UTF-8';

	my $version    = $args->{version};
	my $domain     = $args->{textdomain}
		or error __"textdomain parameter is required";

	my $forms      = $args->{plural_forms};
	unless($forms)
	{	my $nrplurals = $args->{nr_plurals} || 2;
		my $algo      = $args->{plural_alg} || 'n!=1';
		$forms        = "nplurals=$nrplurals; plural=($algo);";
	}

	$self->_createHeader(
		project => $domain . (defined $version ? " $version" : ''),
		forms   => $forms,
		charset => $args->{charset},
		date    => $args->{date}
	);

	$self->setupPluralAlgorithm;
	$self;
}


sub read($@)
{	my ($class, $fn, %args) = @_;
	my $self    = bless {LRLP_index => {}}, $class;

	my $charset = $args{charset};
	$charset    = $1
		if !$charset && $fn =~ m!\.([\w-]+)(?:\@[^/\\]+)?\.po$!i;

	my $fh;
	if(defined $charset)
	{	open $fh, "<:encoding($charset):crlf", $fn
			or fault __x"cannot read in {cs} from file {fn}", cs => $charset, fn => $fn;
	}
	else
	{	open $fh, '<:raw:crlf', $fn
			or fault __x"cannot read from file {fn} (unknown charset)", fn=>$fn;
	}

	local $/   = "\n\n";
	my $linenr = 1;  # $/ frustrates $fh->input_line_number
	while(1)
	{	my $location = "$fn line $linenr";
		my $block    = <$fh>;
		defined $block or last;

		$linenr += $block =~ tr/\n//;

		$block   =~ s/\s+\z//s;
		length $block or last;

		unless($charset)
		{	$charset = $block =~ m/\"content-type:.*?charset=["']?([\w-]+)/mi ? $1
			  : error __x"cannot detect charset in {fn}", fn => $fn;

			trace "auto-detected charset $charset for $fn";
			binmode $fh, ":encoding($charset):crlf";

			$block = decode $charset, $block
				or error __x"unsupported charset {charset} in {fn}", charset => $charset, fn => $fn;
		}

		my $po = Log::Report::Lexicon::PO->fromText($block, $location);
		$self->add($po) if $po;
	}

	close $fh
		or fault __x"failed reading from file {fn}", fn => $fn;

	$self->{LRLP_fn}      = $fn;
	$self->{LRLP_charset} = $charset;

	$self->setupPluralAlgorithm;
	$self;
}



sub write($@)
{	my $self = shift;
	my $file = @_%2 ? shift : $self->filename;
	my %args = @_;

	defined $file
		or error __"no filename or file-handle specified for PO";

	my $need_refs = $args{only_active};
	my @opt       = (nr_plurals => $self->nrPlurals);

	my $fh;
	if(ref $file) { $fh = $file }
	else
	{	my $layers = '>:encoding('.$self->charset.')';
		open $fh, $layers, $file
			or fault __x"cannot write to file {fn} with {layers}", fn => $file, layers => $layers;
	}

	$fh->print($self->msgid(MSGID_HEADER)->toString(@opt));
	my $index = $self->index;
	foreach my $msgid (sort keys %$index)
	{	next if $msgid eq MSGID_HEADER;

		my $rec  = $index->{$msgid};
		my @recs = blessed $rec ? $rec   # one record with $msgid
		  : @{$rec}{sort keys %$rec};    # multiple records, msgctxt

		foreach my $po (@recs)
		{	next if $po->useless;
			next if $need_refs && !$po->references;
			$fh->print("\n", $po->toString(@opt));
		}
	}

	$fh->close
		or failure __x"write errors for file {fn}", fn => $file;

	$self;
}

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

sub charset()  { $_[0]->{LRLP_charset} }
sub index()    { $_[0]->{LRLP_index} }
sub filename() { $_[0]->{LRLP_fn} }


sub language() { $_[0]->filename =~ m![/\\](\w+)[^/\\]*$! ? $1 : undef }

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

sub msgid($;$)
{	my ($self, $msgid, $msgctxt) = @_;
	my $msgs = $self->index->{$msgid} or return;

	return $msgs
		if blessed $msgs
		&& (!$msgctxt || $msgctxt eq $msgs->msgctxt);

	$msgs->{$msgctxt};
}


sub msgstr($;$$)
{	my ($self, $msgid, $count, $msgctxt) = @_;
	my $po   = $self->msgid($msgid, $msgctxt)
		or return undef;

	$count //= 1;
	$po->msgstr($self->pluralIndex($count));
}


sub add($)
{	my ($self, $po) = @_;
	my $msgid = $po->msgid;
	my $index = $self->index;

	my $h = $index->{$msgid};
	$h or return $index->{$msgid} = $po;

	$h = $index->{$msgid} = +{ ($h->msgctxt // '') => $h }
		if blessed $h;

	my $ctxt = $po->msgctxt // '';
	error __x"translation already exists for '{msgid}' with '{ctxt}", msgid => $msgid, ctxt => $ctxt
		if $h->{$ctxt};

	$h->{$ctxt} = $po;
}


sub translations(;$)
{	my $self = shift;
	@_ or return map +(blessed $_ ? $_ : values %$_), values %{$self->index};

	error __x"the only acceptable parameter is 'ACTIVE', not '{p}'", p => $_[0]
		if $_[0] ne 'ACTIVE';

	grep $_->isActive, $self->translations;
}


sub _now() { strftime "%Y-%m-%d %H:%M%z", localtime }

sub header($;$)
{	my ($self, $field) = (shift, shift);
	my $header = $self->msgid(MSGID_HEADER)
		or error __x"no header defined in POT for file {fn}", fn => $self->filename;

	if(!@_)
	{	my $text = $header->msgstr(0) || '';
		return $text =~ m/^\Q$field\E\:\s*([^\n]*?)\;?\s*$/im ? $1 : undef;
	}

	my $content = shift;
	my $text    = $header->msgstr(0);

	for($text)
	{	if(defined $content)
		{	s/^\Q$field\E\:([^\n]*)/$field: $content/im  # change
			|| s/\z/$field: $content\n/;   # new
		}
		else
		{	s/^\Q$field\E\:[^\n]*\n?//im;  # remove
		}
	}

	$header->msgstr(0, $text);
	$content;
}


sub updated(;$)
{	my $self = shift;
	my $date = shift || _now;
	$self->header('PO-Revision-Date', $date);
	$date;
}

### internal
sub _createHeader(%)
{	my ($self, %args) = @_;
	my $date   = $args{date} || _now;

	my $header = Log::Report::Lexicon::PO->new(msgid => MSGID_HEADER, msgstr => <<__CONFIG);
Project-Id-Version: $args{project}
Report-Msgid-Bugs-To:
POT-Creation-Date: $date
PO-Revision-Date: $date
Last-Translator:
Language-Team:
MIME-Version: 1.0
Content-Type: text/plain; charset=$args{charset}
Content-Transfer-Encoding: 8bit
Plural-Forms: $args{forms}
__CONFIG

	my $version = $Log::Report::VERSION || '0.0';
	$header->addAutomatic("Header generated with ".__PACKAGE__." $version\n");

	$self->index->{&MSGID_HEADER} = $header
		if $header;

	$header;
}


sub removeReferencesTo($)
{	my ($self, $filename) = @_;
	sum map $_->removeReferencesTo($filename), $self->translations;
}


sub keepReferencesTo($)
{	my ($self, $keep) = @_;
	sum map $_->keepReferencesTo($keep), $self->translations;
}


sub stats()
{	my $self  = shift;
	my %stats = (msgids => 0, fuzzy => 0, inactive => 0);
	foreach my $po ($self->translations)
	{	next if $po->msgid eq MSGID_HEADER;
		$stats{msgids}++;
		$stats{fuzzy}++    if $po->fuzzy;
		$stats{inactive}++ if !$po->isActive && !$po->useless;
	}
	\%stats;
}

1;