File Coverage

blib/lib/String/BOM.pm

Criterion	Covered	Total	%
statement	37	39	94.8
branch	17	22	77.2
condition	2	3	66.6
subroutine	5	6	83.3
pod	4	4	100.0
total	65	74	87.8

package String::BOM;

# use warnings;
# use strict;

$String::BOM::VERSION = '0.3';

# http://www.unicode.org/faq/utf_bom.html#BOM
# http://search.cpan.org/perldoc?PPI::Token::BOM
%String::BOM::bom_types = (
    "\x00\x00\xfe\xff" => 'UTF-32',
    "\xff\xfe\x00\x00" => 'UTF-32',
    "\xfe\xff"         => 'UTF-16',
    "\xff\xfe"         => 'UTF-16',
    "\xef\xbb\xbf"     => 'UTF-8',
);

sub string_has_bom {
    if ( $_[0] =~ m/^(\x00\x00\xfe\xff|\xff\xfe\x00\x00|\xfe\xff|\xff\xfe|\xef\xbb\xbf)/s ) {
        return $String::BOM::bom_types{$1};
    }
    return;
}

sub strip_bom_from_string {
    my $copy = $_[0];    # Modification of a read-only value attempted at ...
    $copy =~ s/^(\x00\x00\xfe\xff|\xff\xfe\x00\x00|\xfe\xff|\xff\xfe|\xef\xbb\xbf)//s;
    return $copy;
}

sub file_has_bom {

    # Would rather not bring in >0.5MB Fcntl just for this so we do a read() of characters instead of a sysread() of bytes()
    #   sysopen(my $fh, $_[0],&Fcntl::O_RDONLY) or return;
    #   sysread($fh, my $buf, $length_in_bytes_of_biggest_bom);
    open( my $fh, '<', $_[0] ) or return;
    $! = 0;              # yes this happens
    read( $fh, my $buf, 4 ) or return;    # 4 "characters" should be big enough to bring in enough anything in bom_types
    $! = 0;                               # yes this happens
    close($fh) or return;
    $! = 0;                               # yes this happens
    return string_has_bom($buf);
}

sub strip_bom_from_file {
    if ( file_has_bom( $_[0] ) ) {

        # there is [probabaly] a better way to do this (faster, w/ out .bak file, etc), suggestions/patches welcome

        # in-place edit
        my $inplace_error = 0;
        {
            local $^I              = '.bak';
            local @ARGV            = ( $_[0] );
            local $SIG{'__WARN__'} = sub {
                $inplace_error++;

                # my $err = shift();
                # $inplace_error = {
                #     'errno_int' => int($!),
                #     'errno_str' => "$!",
                #     'raw_warn'  => $err,
                # };
            };

            while () {
                if ( $. == 1 ) {
                    print strip_bom_from_string($_);    # ... write stripped line back to the file
                    next;
                }
                print;                                  # ... write the line back to the file
            }
        }

        return if $inplace_error;

        unlink "$_[0].bak" unless $_[1];

        return 1;
    }
    else {
        return if $!;                                   # file_has_bom() must've returned false due to FS issue (hence the "yes this happens" bits above)
        return 1;
    }
}

sub import {
    shift;
    return if !@_;

    my $caller = caller();

    # no strict 'refs';
    for (@_) {
        next if !defined &{$_} || m/\:\'/;
        *{"$caller\::$_"} = \&{$_};
    }
}

1;

__END__