view release on metacpan or  search on metacpan

lib/IO/Socket/DNS/Server.pm  view on Meta::CPAN

                    $i++;
                    last if $i > $ticks;
                }
                print "\n";
                if ($i<$ticks) {
                    print "WARNING! Only downloaded $i/$ticks chunks do refusing to write $file\n";
                    next;
                }
                $contents = pack 'H*', $contents;
                if ($contents) {
                    open my $fh, ">", $file or die "$file: open: $!";
                    print $fh $contents;
                    close $fh;
                }
            }
        }

        if ($downloaded) {
            foreach my $mod (@modules) {
                next if $mod =~ /Win32/ and $^O !~ /Win32/;
                eval "require '$mod'" or die "$mod: Unable to download?: $@";
            }
        }
        else {
            warn "Congratulations! You already had Net::DNS installed.\n";
        }
        my $n = q{$LOADER};
        $n =~ s/\bperl\b/$^X/g;
        print "Now you are safe to run the following:\n\n$n\n\n";
        exit;
    };

    # Strip comments
    $code =~ s/\s+\#.*//g;
    # Fake interpolate $LOADER
    $code =~ s/\$LOADER/$LOADER/g;
    # Fake inerpolate $MODULES
    $code =~ s/\$MODULES/$MODULES/g;
    # Fake interpolate $suffix
    $code =~ s/\$suffix/$suffix/g;
    # Jam true VERSION
    $code =~ s/\$VERSION/$IO::Socket::DNS::VERSION/g;
    # Collapse to reduce transport code
    $code =~ s/\s+/ /g;
    return $code;
}

sub unzip_code {
    my $self = shift;
    my $suffix = $self->{"Suffix"};

    # Short program to CREATE the menu.pl program.
    my $code = q{
        $| = 1;
        use strict;
        use warnings;

        my $interp = $^X;
        if ($interp !~ m{[\\/]}) {
            # Make fully qualified absolute search path
            foreach my $path (split m/:/, $ENV{PATH}) {
                my $try = "$path/$interp";
                if (-e $try) {
                    $interp = $try;
                    last;
                }
            }
        }

        if (-e "menu.pl") {
            print "File menu.pl already exists. You must remove it to regenerate a fresh copy.\n";
        }
        else {
            print "Creating menu.pl ...\n";
            open my $fh, ">", "menu.pl" or die "menu.pl: open: $!\n";
            print $fh qq{\#!$interp -w\n};
            print $fh q{
                use strict;
                print "Loading MENU. Please wait...\n";
                my $res = eval {
                    require Net::DNS::Resolver;
                    Net::DNS::Resolver->new;
                };
                my $get_txt = $res ? sub {
                    my $q = shift;
                    # Fast method, but Net::DNS may not be installed.
                    return eval{[$res->query($q,'TXT')->answer]->[0]->txtdata};
                } : sub {
                    my $q = shift;
                    # Slower, but better than relying on Net::DNS to be installed.
                    return $1 if `nslookup -type=TXT $q. 2>&1`=~/"(.+)"/;
                    sleep 1;
                    return $1 if `nslookup -type=TXT $q. 2>&1`=~/"(.+)"/;
                    return undef;
                };
                $_="";
                my $i=0;
                while (++$i and my $b=$get_txt->("menu$i.$suffix")) {$_.=$b}
                $_=pack 'H*', $_;
                if (open my $fh, "+<", $0) {
                    # Self modifying code to spead up future executions.
                    print $fh "#!$^X -w\n";
                    print $fh $_;
                    close $fh;
                    exit if 0 == system $0;
                }
                eval or warn "$_:$@";
            };
            close $fh;
        }
        chmod 0755, "menu.pl";
        print "You can now run: ".($^O=~/Win32/i?"$interp -w ":"./")."menu.pl\n\n";
        exit;
    };
    # Strip comments
    $code =~ s/\s+\#.*//g;
    # Fake interpolate $suffix
    $code =~ s/\$suffix/$suffix/g;
    # Collapse to reduce transport code
    $code =~ s/\s+/ /g;
    return $code;

lib/IO/Socket/DNS/Server.pm  view on Meta::CPAN

        else {
            unshift @INC, "lib";
        }

        my $res = eval {
            require Net::DNS::Resolver;
            Net::DNS::Resolver->new;
        };
        my $get_txt = $res ? sub {
            my $q = shift;
            # Fast method, but Net::DNS may not be installed.
            return eval{[$res->query($q,'TXT')->answer]->[0]->txtdata};
        } : sub {
            my $q = shift;
            # Slower, but better than relying on Net::DNS
            return $1 if `nslookup -type=TXT $q. 2>&1`=~/"(.+)"/;
            warn "**CHOKE1** $q\n";
            sleep 1;
            return $1 if `nslookup -type=TXT $q. 2>&1`=~/"(.+)"/;
            warn "**CHOKE2** $q\n";
            sleep 1;
            return $1 if `nslookup -type=TXT $q. 2>&1`=~/"(.+)"/;
            warn "**CHOKE3** $q\n";
            return undef;
        };
        my $install = sub {
            my ($pre,$file,$mode) = @_;
            my $dir = "";
            while ($file =~ m{([^/]+)/}g) {
                $dir .= $1;
                mkdir $dir, 0755;
                $dir .= "/";
            }
            my $i = 0;
            my $contents = "";
            print "Downloading $file ...\n";
            my $ticks = 0;
            while (my $txt = $get_txt->("$pre$i.$suffix")) {
                if ($i) {
                    $contents .= $txt;
                    print sprintf "\r(%d/%d) %.1f%%", $i, $ticks, $i/$ticks*100;
                }
                elsif ($txt =~ /^\d+$/) {
                    $ticks = $txt;
                    print "\r0/$ticks";
                }
                else {
                    die "$pre$i: Invalid DNS cache: $txt\n";
                }
                $i++;
                last if $i > $ticks;
            }
            print "\n";
            $contents = pack 'H*', $contents;
            if ($contents) {
                open my $fh, ">", $file;
                if ($file =~ /\.pl$/) {
                    my $interp = $^X;
                    if ($interp !~ m{[\\/]}) {
                        # Make fully qualified absolute search path
                        foreach my $path (split m/:/, $ENV{PATH}) {
                            my $try = "$path/$interp";
                            if (-e $try) {
                                $interp = $try;
                                last;
                            }
                        }
                    }
                    unless ($contents =~ s{^\#\!/\S+}{\#\!$interp}) {
                        print $fh "#!$interp\n";
                    }
                }
                print $fh $contents;
            }
            chmod $mode, $file;
            return 1;
        };

        if ($choice == 6) {
            if (eval {
                require Net::DNS;
                require Net::DNS::Resolver;
            }) {
                warn "Congratulations! Net::DNS already works for you: $INC{'Net/DNS.pm'}\n";
            }
            else {
                my @PREREQ_PM = qw(
                    IO::Socket
                );
                if ($^O eq "MSWin32") {
                    push @PREREQ_PM, qw(
                        Win32::Registry
                        Win32::IPHelper
                    );
                }
                my %broken = ();
                foreach my $module (@PREREQ_PM) {
                    if (!eval "require $module") {
                        $broken{$module} = "$@";
                    }
                }
                if (scalar keys %broken) {
                    foreach my $broken (sort keys %broken) {
                        warn "Unable to install Net::DNS without Prerequisite Module $broken: $broken{$broken}\n";
                    }
                    exit;
                }
                warn "Please wait while Net::DNS is downloaded and installed ...\n";
                if (my $netdns = $get_txt->("netdns.$suffix")) {
                    eval $netdns or warn $@;
                }
            }
            exit;
        }

        for (my $i=0;$i<@$files;$i++) {
            if ($i<$choice) {
                my ($txt,$file,$mode) = @{ $files->[$i] };
                if ($i) {
                    # Don't bother downloading if it's already here.
                    next if -e $file;