view release on metacpan or  search on metacpan

script/maint_ip_world_db  view on Meta::CPAN

    for ($i=0; $i < @URLS; $i++) {
      if (defined $in[$i]
       &&   $start[$i] <= $lastOut) {
        if ($last [$i] <= $lastOut) {getLine($i)}
        else {$start[$i] = $lastOut+1}
    } }
    # for breaking
    # my $zzz=0;
  }
  # make a last "hole" entry if it's needed for the binary search
  if ($lastOut < 0xFFFFFFFF) {
    out($lastOut + 1);
    push @ccs, 26*26;
    $unknowns++;
  }
  # output the country code table
  my $word;
  for ($i=0; $i < @ccs; $i++) {
    my $j = $i%3;
    if (!$j)      {$word  = $ccs[$i] << 20}
    elsif ($j==1) {$word |= $ccs[$i] << 10}
    else      {out($word |  $ccs[$i])}
  }
  # print a last incomplete word
  if (@ccs%3) {out($word)}
  # output file complete
  close   DAT   or die "Can't close output file $outfn: $!";
  if ($dual_out) {
    close DATBE or die "Can't close output file $outfn2: $!"}

  # set the mod time of the result file to that of the source file
  utime($latestMod, $latestMod, $outfn)==1
    or die "Can't make modification time of $outfn match that of source file: $1";
  if ($dual_out) {
    utime($latestMod, $latestMod, $outfn2)==1
      or die "Can't make modification time of $outfn2 match that of source file: $1";

    # since we can't trust a mod time to make it through dist-making and unpacking,
    #  put the mod time for these files into an accompanying file.
    my $mtfn = $dd.'modtime.dat';
    open DAT, ">$mtfn" or die "Can't open for $mtfn write: $!";
    print DAT pack 'N', $latestMod;
    close DAT or die "Can't close $mtfn: $!";
  }
  # delete the source files
  unlink(@fns) == @fns or die "Can't delete the source files";

  # if we just made a .tmp file, cycle it (them) to become the target file
  if ($outfn =~ /tmp$/) {
    if ($testing) {
      eval "require Module::Build;";
      if ($@) {die "Can't load Module::Build: $@"}
      my $build = Module::Build->current();

      if ($build->is_unixish()) {
        # prevent making a root-owned file in blib
        my ($old_uid, $old_gid) = (CORE::stat $replfn)[4..5];
        my ($new_uid, $new_gid) = (CORE::stat $outfn )[4..5];
        if ($new_uid != $old_uid
         || $new_gid != $old_gid) {
          chown ($old_uid, $old_gid, $outfn)==1
            or die "Can't transfer owner:group from old $replfn to new: $!";
    } } }
    # old file(s) -> .bak[xx] then new file(s) -> .dat or .le or .be
    my @renamers = $dual_out ? (\$outfn, 'le',  'bakle', \$outfn2, 'be', 'bakbe')
                             : (\$outfn, 'dat', 'bak');
    while (@renamers) {
      my ($targfn, $bakfn);
      ($targfn = ${$renamers[0]}) =~ s/[^.]+$/$renamers[1]/e;
      ($bakfn  = ${$renamers[0]}) =~ s/[^.]+$/$renamers[2]/e;
      rename ($targfn, $bakfn)==1
        or die "Can't rename $targfn to $bakfn: $!";
      rename (${$renamers[0]}, $targfn)==1
        or die "Can't rename ${$renamers[0]} to $targfn: $!";;
      ${$renamers[0]} = $targfn;
      splice (@renamers, 0, 3);
  } }
  # make the new output file(s) read-only
  chmod(0444, $outfn) == 1
    or die "Can't set permissions of $outfn to read-only: $!";
  if ($dual_out) {
    chmod(0444, $outfn2) == 1
      or die "Can't set permissions of $outfn2 to read-only: $!";
  }
  # if the user entered a command to run at this time, do so
  #   but not if we're just testing
  if (!$testing) {
    eval 'require IP::World::ConfigData';
    if (!$@
     && ($_ = IP::World::ConfigData->config('cmd'))) {system $_}
  }  
  # show that we updated the DB (no one may be watching...)
  my ($mday, $mon, $year) = (localtime($latestMod))[3..5];
  my $mod_date = $moname[$mon].sprintf("-%d-", $mday).($year+1900);
  print "Wrote IP::World database".($dual_out && $dd ? " to $dd" : '')
        .", including ".(scalar(@ccs)-$unknowns)
        ." country blocks and $unknowns unknown blocks\n";
  # my $zzz = 0
} else {
  print "IP::World database is up-to-date\n";
}
#### end of main, start of subs ####

# make a 32-bit packed value
sub pack32 {
  my $s = pack($_[0], $_[1]);
  if (length($s) <= 4) {return $s}
  if (unpack('N', $s) == $_[1]) {return substr($s, -4)}
  return substr($s, 0, 4);
}
# output a word to the output file(s)
sub out {
    print DAT   pack32($mainpack, $_[0]);
  if ($dual_out) {
    print DATBE pack32('N',       $_[0]);
} }
# read a line from a source file
sub getLine {
  my ($i) = @_;
  my (@f, @l, $j, $cc);
  my $fh = $in[$i];