#!/usr/bin/perl -w use strict; use Getopt::Long; use HTTP::Status; use LWP::Simple; use Unicode::Map; my $emptyMap = 0; my $numWarnings = 0; my $numErrors = 0; my %opt = ( ); main: { $|=1; _getOptions ( ); _mirror ( ); _summarizeResult ( ); exit $numErrors; } sub _getOptions { GetOptions ( \%opt, "update" ); if ( !$opt{"update"} ) { usage ( ); } } sub usage { print <<EOF; Usage: mirrorMappings --update [\@ids] An utility for hardcore Unicode::Map perl developers. It mirrors a collection of textual Unicode mapping files in order to create binary mapping files. Mirrors the charsets for the ids specified. If none specified the whole set mentioned in control file REGISTRY will be updated. Can cause quite some net traffic! EOF exit 1; } sub _mirror ( ) { $emptyMap = new Unicode::Map ( ); if ( @ARGV ) { for ( @ARGV ) { _mirrorOne ( $_ ); } } else { for ( sort $emptyMap->ids() ) { _mirrorOne ( $_ ); } } } sub _mirrorOne { my ($id) = @_; print "Processing \"$id\": "; $id = $emptyMap -> id ( $_ ); my $srcURL = $emptyMap -> srcURL ( $id ); my $srcCopy = $emptyMap -> src ( $id ); if ( !$srcCopy ) { print "Error!\n"; print "! No 'src:' entry for this charset in file 'REGISTRY'!\n"; $numErrors++; return; } if ( !_mkFilePath($srcCopy) ) { print "Error!\n"; print "Couldn't create directory! ($!)\n"; $numErrors++; return; } if ( !$srcURL ) { print "Warning!\n"; print <<EOF; ? No source URL for charset "$id"! This indicates an error unless you added an charset source manually to the control file "REGISTRY" and don't want to update it automatically! EOF $numWarnings++; return; } my $existed = -e $srcCopy; $^W = 0; # no warnings here my $rc; for ( 1..2 ) { $rc = mirror ( $srcURL, $srcCopy ); # If a BAD_REQUEST occurs for stupid reasons try another time. last unless $rc == RC_BAD_REQUEST; } $^W = 1; if ( is_error($rc) ) { my $msg = status_message ( $rc ); print "Error!\n"; print "! Couldn't mirror \"$srcURL\"! ($rc: $msg)\n"; $numErrors++; return; } if ( !$existed ) { print "created \"$srcCopy\"\n"; } else { if ( $rc==RC_NOT_MODIFIED ) { print "is uptodate.\n"; } else { print "updated.\n"; } } } sub _summarizeResult { if ( $numWarnings==0 && $numErrors==0 ) { print "Ok. Everything went fine!\n"; } elsif ( $numErrors>0 ) { my $msg; $msg = "$numErrors error"; $msg .= "s" if $numErrors>1; $msg .= ", $numWarnings warning" if $numWarnings>0; $msg .= "s" if $numWarnings>1; $msg .= "."; print "Error! Encountered $msg\n"; } else { my $msg; $msg = "$numWarnings warning"; $msg .= "s" if $numWarnings>1; $msg .= "."; print "Warning! Possible trouble! $msg\n"; } } ## ## Utilities ## sub _mkFilePath { my ( $filePath ) = @_; my $file = substr ( $filePath, rindex($filePath,"/")+1 ); my $path = $filePath; $path =~ s/$file$//; _mkPath ( $path ); } sub _mkPath { my ( $path ) = @_; my $current = ""; for (grep {$_} split /\//, $path) { $current .= "/$_"; if ( !-d $current ) { if ( !_mkdir($current) ) { return 0; } } } 1} sub _mkdir { my ( $path ) = @_; if ( !-d $path ) { if ( !mkdir ($path, 0777 ) ) { return 0; } } 1}
Generated by dwww version 1.15 on Sat Jun 15 19:39:37 CEST 2024.