view release on metacpan or  search on metacpan

lib/Sys/Export.pm  view on Meta::CPAN

      }
   }
   return %attrs;
}


sub round_up_to_pow2($n) {
   croak "Not defined for negative numbers" unless $n > 0;
   return 1 if $n <= 1;
   --$n;
   $n |= $n >> 1;
   $n |= $n >> 2;
   $n |= $n >> 4;
   $n |= $n >> 8;
   $n |= $n >> 16;
   $n |= $n >> 32;
   return $n+1;
}

sub round_up_to_multiple($n, $pow2) {
   croak "Not defined for negative numbers" unless $n > 0;
   my $mask= $pow2-1;
   return ($n + $mask) & ~$mask;
}


if (eval { require File::Map; }) {
   eval q{
      sub map_or_load_file($filename, $offset=0, $length=undef) {
         my $buf;
         defined $length? File::Map::map_file($buf, $filename, "<", $offset, $length)
            : File::Map::map_file($buf, $filename, "<", $offset, $length);
         return \$buf;
      }
      1;
   } or die "$@";
} else {
   *map_or_load_file= *_load_file;
}

sub _load_file($filename, $offset= 0, $length= undef) {
   open my $fh, "<:raw", $filename
      or die "open($filename): $!";
   my $size= -s $fh;
   croak "Offset beyond end of file ($filename, $offset > $size)" if $offset > $size;
   $length //= $size - $offset;
   my $buf= '';
   if ($length) {
      if ($offset > 0) {
         sysseek($fh, $offset, 0) == $offset
            or croak "sysseek($filename, $offset): $!";
      }
      sysread($fh, $buf, $length) == $size
         or die "sysread($filename, $size): $!";
   }
   \$buf;
}


sub filedata {
   state $loaded= require Sys::Export::LazyFileData;
   Sys::Export::LazyFileData->new(@_);
}


sub write_file_extent($fh, $addr, $size, $data_ref, $ofs=0, $descrip=undef) {
   $log->tracef("write %s at 0x%X-0x%X from buf size 0x%X%s",
      $descrip//'blocks', $addr, $addr+$size, length($$data_ref), $ofs? sprintf(" ofs 0x%X", $ofs) : ''
      ) if $log->is_trace;
   return unless $size > 0;
   if (defined $addr) {
      my $reached= sysseek($fh, $addr, 0) // croak "sysseek($addr): $!";
      $reached == $addr or croak "sysseek($addr) arrived at $reached instead of $addr";
   }
   $ofs //= 0;
   my $avail= $data_ref? (length($$data_ref) - $ofs) : 0;
   my $second;
   # always write full size, padding with zeroes
   if ($avail < $size) {
      # If the scalar is particularly large, do two writes instead of reallocating the buffer.
      if ($avail > 0x100000) {
         my $first_write= $avail - ($avail & 0xFFF);
         $second= pack 'a'.($size-$first_write), substr($$data_ref, $first_write);
         $size= $first_write;
      } else {
         my $data= pack 'a'.$size, ($avail > 0? substr($$data_ref, $ofs) : '');
         $data_ref= \$data;
         $ofs= 0;
      }
   }
   my $wrote= syswrite($fh, $$data_ref, $size, $ofs);
   croak "syswrite: $!" if !defined $wrote;
   croak "Unexpected short write ($wrote != $size)" if $wrote != $size;
   if (length $second) {
      $wrote= syswrite($fh, $second);
      croak "syswrite: $!" if !defined $wrote;
      croak "Unexpected short write ($wrote != $size)" if $wrote != length($second);
   }
   return 1;
}

if (eval { pack('Q<', 1) }) {
   *_pack= \*CORE::pack;
   *_unpack= \*CORE::unpack;
} else {
   eval <<'END';
   # On perl without 64-bit support, replace all 'Q' with 32-bit operations
   # This does not handle full pack syntax, just what is used in this module collection.
   sub _pack {
      my $fmt= shift;
      my $new_fmt= '';
      my @new_args;
      require Math::BigInt;
      my $mask32= Math::BigInt->new('4294967295');
      for (split / +/, $fmt) {
         if ($_ eq 'Q>') {
            # Convert a 64-bit integer into two 32-bit big-endian arguments
            $new_fmt .= 'NN';
            my $qw= Math::BigInt->new(shift);
            push @new_args, ($qw >> 32)->numify(), ($qw & $mask32)->numify();
         } elsif ($_ eq 'Q<') {