如何在 Perl 中捕获子例程中的所有 "warn" 调用

Question

我正在使用 Twig Parser 执行多项帐户验证检查 - 并希望在我的 'process_account' 子例程中获取所有 'warn' 调用（以显示警告数量每个帐户都有 shown/etc).

以下是我的代码块。

use strict;
use warnings;
use XML::Twig; 
use Time::Piece; 

use vars qw/$user/; #User Choice (grabbed via another sub routine)

    sub process_account {
        my ( $twig, $account ) = @_;
        print "Account Name: ", $account -> first_child_text('Id'), "\tAccount Status: ", ($account -> first_child_text('Locked') eq 'false' ? "Not Locked" : "LOCKED"), "\n";
        my $logindate = join ( "-", map { $account -> first_child('LastLoginDate')->att($_) // 0 } qw ( year month day-of-month) );
        my $createdate = join ( "-", map { $account -> first_child('CreationDate')->att($_) // 0 } qw ( year month day-of-month) );

        if ($user == 1){
            #Checking if the LoginID length is between 7-15 & it only contains alphanumeric characters (the length limit will be changed as per the necessity)
            if ( $account -> first_child_text('Id') !~ /^[A-Za-z0-9_-]+$/ || 7 > length $account -> first_child_text('Id') || 14 < length $account -> first_child_text('Id') ) { 
                warn "\tALERT: Login Name is out of the defined Parameters.\n", return;
            }
        }
        if ($user == 2){
            # Checking if the LastLoginDate is older than the creation date.
            if ( eval{ Time::Piece -> strptime ( $createdate, "%Y-%m-%d" )} > eval{Time::Piece -> strptime ( $logindate, "%Y-%m-%d" )} ) {
                warn "\tALERT: Last Login Date is older than the creation date.\n", return; 
            }
        }
        if ($user == 3){
            #Checking if the Login Count has been incremented since the creation of this account.
            if (    $logindate eq 0 && $account -> first_child_text('LoginsCount') eq '0') {
                warn "\tALERT: Login Date exists but the Login Count is still '0'.\n", return; 
                }
            }
  $twig -> purge; #For Emptying the processed data (so far).
    }
my $twig = XML::Twig -> new ( twig_handlers => { 'Account' => \& process_account } );
$twig -> parsefile ($file);

我尝试了几种选择（例如使用 Warn）

local $SIG{__WARN__} = sub {
    state %WARNS;
    my $message = shift;
    return if $WARNS{$message}++;
    logger('warning', $message);
};
if ( (%WARNS) > 0 ) { #things i would like to do
   }

但是 none 选项有效，非常感谢您在这方面的指导。

Answer 1

我认为我不会通过 warn 执行此操作，而只是保留错误事件的日志。

例如

my %warnings; 

sub log_warning { 
    my ( $account_id, $warning ) = @_;
    warn "$account id has problem with $warning\n";
    push ( @{$warnings{$warnings}}, $account_id );  
}

这将填充一个警告散列，您将获得一个消息列表以及哪些帐户 ID 触发了它。

您可以通过以下方式调用它：

log_warning ( $account -> first_child_text('Id'), 
            "Login Date exists but the Login Count is still 0");

解析完成后，您可以通过以下方式提取：

foreach my $message ( keys %warnings ) { 
    print scalar @{ $warnings{$message}} . " warnings found of ". $message,"\n";
    print "Accounts:\n"; 
    print join ("\n\t", @{$warnings{$message}} ), "\n";
}

反正就是这样。

如果您只是关注失败的帐户 - 添加：

my %failed_accounts;

在那个子中，- 要么只是一个计数：

$failed_accounts{$account_id}++;

或者如果您想要失败列表：

push ( @{$failed_accounts{$account_id}}, $message );

然后您可以使用以下方式报告：

foreach my $acc_id ( keys %failed_accounts ) { 
   print $acc_id, " has ", scalar @{$failed_accounts{$acc_id}}, " errors\n";
   print join ( "\n\t", @{$failed_accounts{$acc_id}}),"\n";
}

如何在 Perl 中捕获子例程中的所有 "warn" 调用

How to catch all the "warn" calls in your sub-routine in Perl

xml

validation

perl

sax

xml-parsing