-# warn about various red flags in loc strings
-foreach my $str ( sort keys %FILECAT ) {
- my $entry = $FILECAT{$str};
- my $entry_count = @$entry;
-
- # doesn't exist in the current codebase, ignore for now
- next if $entry_count == 0;
-
- my ($filename, $line) = @{ $entry->[0] };
-
- my $location = "$filename line $line" . ($entry_count > 1 ? " (and ".($entry_count-1)." other places)" : "");
-
- if ($str =~ /^\s/m || $str =~ /\s$/m || $str =~ /\\n$/m) {
- warn "Extraneous whitespace in '$str' at $location\n";
- }
-
- if ($str =~ /([\$\@]\w+)/) {
- warn "Interpolated variable '$1' in '$str' at $location\n";
- }
-}
-
-
-sub extract_strings_from_code {
- my $file = $_;
-
- local $/;
- return if ( -d $_ || !-e _ );
- return
- if ( $File::Find::dir =~
- qr!lib/blib|lib/t/autogen|var|m4|local|share/fonts! );
- return if ( /\.(?:pot|po|bak|gif|png|psd|jpe?g|svg|css|js)$/ );
- return if ( /~|,D|,B$|extract-message-catalog$|tweak-template-locstring$/ );
- return if ( /StyleGuide.pod/ );
- return if ( /^[\.#]/ );
- return if ( -f "$_.in" );
-
- print "Looking at $File::Find::name\n";
- my $filename = $File::Find::name;
- $filename =~ s'^\./'';
- $filename =~ s'\.in$'';
-
- unless (open _, '<', $file) {
- print "Cannot open $file for reading ($!), skipping.\n";
- return;
- }
-
- my $re_space_wo_nl = qr{(?!\n)\s};
- my $re_loc_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc $re_space_wo_nl* $}mx;
- my $re_loc_qw_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_qw $re_space_wo_nl* $}mx;
- my $re_loc_pair_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_pair $re_space_wo_nl* $}mx;
- my $re_loc_left_pair_suffix = qr{$re_space_wo_nl* \# $re_space_wo_nl* loc_left_pair $re_space_wo_nl* $}mx;
- my $re_delim = $RE{delimited}{-delim=>q{'"}}{-keep};
-
- $_ = <_>;
-
- # Mason filter: <&|/l>...</&>
- my $line = 1;
- while (m!\G(.*?<&\|/l(.*?)&>(.*?)</&>)!sg) {
- my ( $all, $vars, $str ) = ( $1, $2, $3 );
- $vars =~ s/[\n\r]//g;
- $line += ( $all =~ tr/\n/\n/ );
- $str =~ s/\\'/\'/g;
- #print "STR IS $str\n";
- push @{ $FILECAT{$str} }, [ $filename, $line, $vars ];
- }
-
- # Localization function: loc(...)
- $line = 1;
- pos($_) = 0;
- while (m/\G(.*?\bloc$RE{balanced}{-parens=>'()'}{-keep})/sg) {
- my ( $all, $match ) = ( $1, $2 );
- $line += ( $all =~ tr/\n/\n/ );
-
- my ( $vars, $str );
- if ( $match =~
- /\(\s*($re_delim)(.*?)\s*\)$/so ) {
-
- $str = substr( $1, 1, -1 ); # $str comes before $vars now
- $vars = $9;
- }
- else {
- next;
- }
-
- $vars =~ s/[\n\r]//g;
- $str =~ s/\\'/\'/g;
-
- push @{ $FILECAT{$str} }, [ $filename, $line, $vars ];
- }
-
- # Comment-based mark: "..." # loc
- $line = 1;
- pos($_) = 0;
- while (m/\G(.*?($re_delim)[\}\)\],;]*$re_loc_suffix)/smgo) {
- my ( $all, $str ) = ( $1, $2 );
- $line += ( $all =~ tr/\n/\n/ );
- unless ( defined $str ) {
- warn "Couldn't process loc at $filename:$line";
- next;
- }
- $str = substr($str, 1, -1);
- $str =~ s/\\'/\'/g;
- push @{ $FILECAT{$str} }, [ $filename, $line, '' ];
- }
-
- # Comment-based qw mark: "qw(...)" # loc_qw
- $line = 1;
- pos($_) = 0;
- while (m/\G(.*?(?:qw\(([^)]+)\)[\}\)\],;]*)?$re_loc_qw_suffix)/smgo) {
- my ( $all, $str ) = ( $1, $2 );
- $line += ( $all =~ tr/\n/\n/ );
- unless ( defined $str ) {
- warn "Couldn't process loc_qw at $filename:$line";
- next;
- }
- foreach my $value (split ' ', $str) {
- push @{ $FILECAT{$value} }, [ $filename, $line, '' ];
- }
- }
-
- # Comment-based left pair mark: "..." => ... # loc_left_pair
- $line = 1;
- pos($_) = 0;
- while (m/\G(.*?(?:(\w+|$re_delim)\s*=>[^#\n]+?)?$re_loc_left_pair_suffix)/smgo) {
- my ( $all, $key ) = ( $1, $2 );
- $line += ( $all =~ tr/\n/\n/ );
- unless ( defined $key ) {
- warn "Couldn't process loc_left_pair at $filename:$line";
- next;
- }
- $key =~ s/\\'/\'/g;
- push @{ $FILECAT{$key} }, [ $filename, $line, '' ];
- }