This section is the place to post useful code ‐ anything from one-liners to full-blown frameworks and apps. (Perl poetry and obfuscated code should be posted in those respective sections.)

CUFP's
Hopfield Neural Network in perl6
1 direct reply — Read more / Contribute 		by holyghost
on Jun 29, 2018 at 22:53
    A small implementation of an Artificial Neural Network using Hopfield neurons, synapses and a simple training system : 
    unit module ann;

use ann::HopfieldSynaps;

class HopfieldNeuron is export {

        has @.inputsynapses;
        has @.outputsynapses;

        has $.input;

        method BUILD($y1 = 1000000.rand) {
                $.input = $y1;

        }

        method fire() {

                ### with training update weights
                loop (my $i = 0; $i < @.inputsynapses.length; $i++) {
                        if (@.inputsynapses[$i].weight * @.inputsynaps
+es[$i].outputneuron.input >= 0) {
                                @.inputsynapses[$i].outputneuron.input
+ = 1;
                        } else {
                                @.inputsynapses[$i].outputneuron.input
+ = 0;
                        }
                }
        }


}

    [download]
    unit module ann;

use ann::HopfieldNeuron;

class HopfieldSynaps is export {

        has $.weight;
        has $.inputneuron;
        has $.outputneuron;

        method BUILD($inputneuron, $outputneuron, $y1 = 1000000.rand) 
+{
                $.weight = $y1;
        }

};

    [download]
    unit module ann;

use ann::HopfieldNeuron;
use ann::HopfieldSynaps;

class HopfieldNN is export {

        has @.neurons;

        method BUILD($size) {

                @.neurons = ();
                loop (my $n = 0; $n < $size; $n++) {

                        push (@.neurons, HopfieldNeuron.new());

                }

                loop (my $m = 0; $m < $size; $m++) {
                        loop (my $j = 0; $j < $size; $j++) {
                                push(@.neurons[$j].inputsynapses, Hopf
+ieldSynaps.new());
                                @.neurons[$j].inputsynapses[$j].output
+neuron =
                                        @.neurons[$m];

                        }
                }
                loop (my $i = 0; $i < $size; $i++) {
                        loop (my $j = 0; $j < $size; $j++) {
                                push(@.neurons[$j].outputsynapses, Hop
+fieldSynaps.new());
                                @.neurons[$j].outputsynapses[$j].outpu
+tneuron =
                                        @.neurons[$i];

                        }
                }

        }

        ### repeat this to train the network
        method start(@inputs) {

                ### the inputs length is less than the full neuron lis
+t
                ### the first neurons made in the constructor are the 
+inputs
                ### of the network

                loop (my $i = 0; $i < @inputs.length; $i++) {

                        @.neurons[$i].input = @inputs[$i];
                }
                loop (my $j = 0; $j < @.neurons.length; $j++) {

                        @.neurons[$j].fire();

                }
        }

    [download]
            method start2(@inputs) {
                ### without any traning, first neurons are for the inp
+ut pattern

                loop (my $n = 0; $n < @inputs.length; $n++) {
                        @.neurons[$n].input = @inputs[$n];
                }

                loop (my $i = 0; $i < @.neurons.length; $i++) {
                        loop (my $j = 0; $j < @.neurons.length; $j++) 
+{
                                loop (my $k = 0; $k < @.neurons.length
+; $k++) {

                                        if ($k == $j) { next; };

                                @.neurons[$i].inputsynapses[$j].weight
+ += (2 * @.neurons[$i].inputsynapses[$j].outputneuron.input - 1) * (2
+ * @.neurons[$i].inputsynapes[$k].outputneuron.input -1);
                                }
                        }
                }
        }
};

    [download]
Tk Bandwidth use indicator
1 direct reply — Read more / Contribute 		by zentara
on Jun 29, 2018 at 13:45
    Hi, I was looking for a simple program to display my bandwidth usage. I tried many c programs, nload, nethogs, etc, but to my dismay they often jumped to 100% cpu usage, and more often than not, they needed root priviledges to run. Ugh. So I found a bash shell script which is floating around on the search engines which did the trick. The problem with it, was that it was a scrolling display in an xterm, and I always had to set the Window Manager option on the xterm to "Stay on Top". It was a hassle plus it didn't look sweet. So I put the basic idea from the shell script into a Tk script, and I have something useful enough to post here. :-)

    You set your interface to watch on the command line, as first argument, or it defaults to eth0. I placed it just above the lower right corner to stay out of most things way. Once the display is started, a left mouse button click on it kills it.

    It also has a non-blocking sleep (thx to Slaven Reszic) that you might find useful in other Tk scripts. 

    #!/usr/bin/perl
use warnings;
use strict;
use Tk;

#specify interface on commandline or here
my $iface = shift || 'eth0';  #correction

my $mw = new MainWindow;
# I have my toolbar at the top, so
# I like my info boxes at the bottom
$mw->geometry('-50-50');
$mw->overrideredirect(1);
$mw->configure(-cursor => 'pirate'); #:-)

$mw->fontCreate('big',
    -family=>'courier',
    -weight=>'bold',
    -size=> 18);

my $bw = $mw->Label(-text=>'                ',
            -font=>'big',
            -bg=>'black', -fg=>'yellow')->pack
                         (-side=>'left',-fill =>'both');

# left click exits program
$mw->bind('<1>' => sub{exit});

#refresh every 1.5 seconds
my $id = Tk::After->new($mw,1500,'repeat',\&refresh);

MainLoop;

sub refresh{

my $r0 = `cat /sys/class/net/$iface/statistics/rx_bytes`;
my $t0 = `cat /sys/class/net/$iface/statistics/tx_bytes`;
tksleep($mw, 1000);
my $r1 = `cat /sys/class/net/$iface/statistics/rx_bytes`;
my $t1 = `cat /sys/class/net/$iface/statistics/tx_bytes`;

my $rr = sprintf ("%03d",($r1 - $r0)/1024);
my $tr = sprintf ("%03d",($t1 - $t0)/1024);

$bw->configure(-text=>"Rx: $rr kBs || Tx: $tr kBs");
}

sub tksleep {
  # Like sleep, but actually allows the display to be
  # updated, and takes milliseconds instead of seconds.
  # A non-blocking sleep for the eventloop
   my $mw = shift;
   my $ms = shift;
   my $flag = 0;

   $mw->after($ms, sub { $flag++ });
   $mw->waitVariable(\$flag);
}

    [download]
    I'm not really a human, but I play one on earth. ..... an animated JAPH
Check your CPAN modules for use vars
3 direct replies — Read more / Contribute 		by usemodperl
on Jun 25, 2018 at 18:37
    Edit: Since no one likes my joke about use vars this node has been amended to a more useful version of the program: 

    #!/usr/bin/perl ##################################
# Check installed *CPAN* modules for COMMENTS!   #
# Because CPAN modules have a lot of COMMENTS!   #
# https://perlmonks.org/index.pl?node_id=1217408 #
##################################################

use strict;
use warnings;

use Config '%Config';
use ExtUtils::Installed;

for (split $Config{path_sep}, $ENV{PATH}) {
   $|++ if -x "$_/grep"
}
die "you need grep" unless $|;

my $time = time;
my $perl = ExtUtils::Installed->new;
my @cpan = $perl->modules();
my @temp = ();

for (@cpan) {
    my @cpan = $perl->files($_);
    push @temp, @cpan;
}
@cpan = grep /site.*\.pm$/, @temp;

my $opt = 0;

if (@ARGV) { $opt = 1 }
else {
print qq~Checking CPAN modules for COMMENTS in Perl versio~.
qq~n $^V\n(Invoke with any arg to skip questions and gener~.
qq~ate a list of modules.)\n\n~;

print qq~The list may be big and printing progress makes i~.
qq~t a bit slower.\nDefault: display progress, format outp~.
qq~ut and print offending lines of code.\nPress return to ~.
qq~start or n for no progress and list output. y/N~;

chomp($opt = <STDIN>); $opt = 1 if $opt and lc $opt eq 'n';
}
my $INC = join '|', @INC;
my $acme   = 0;
my $grep   = 0;

for my $cpan (@cpan) {
   print "\rChecking: ","$acme\tFound: $grep\t" unless $opt;
   if(@_ =`grep '^#' $cpan`) {
      @_ = grep !/^#(pod|[\-=~\*]|[#]{5,}|\s*\n)/,@_; # FAKE
      next unless scalar @_;
      (my $name = $cpan) =~ s/($INC)//;
      $name =~ s,^/,,;
      $name =~ s,/,::,g;
      $name =~ s/\.pm$//;
      s/^\s+/  / for @_;
      $_{$name} = join "\n ", @_;
      $grep++
   }
   $acme++
}
if ($opt) {
   print "$_\n" for sort keys %_
}
else {
   $perl = scalar keys %_;
   $time = time - $time;

   print qq~$perl CPAN modules (out of $acme) found with COMMENTS!\n~;
   print "$_:\n $_{$_}","-"x60,"\n" for sort keys %_;
   print qq~$perl CPAN modules (out of $acme) found with COMMENTS!\n~;
   print "That took $time secs (grep searched ",sprintf("%0d",$perl/$t
+ime),
   " modules/sec).\n";
}

    [download]


    ORIGINAL:

    I heard the news today:
      Removal of use vars

      The usage of use vars has been discouraged since the introduction of our in Perl 5.6.0. Where possible the usage of this pragma has now been removed from the Perl source code.

    And had to find out how many modules are afflicted on my system (5.26.2):

    905 CPAN modules (out of 4918) found with "use vars"!

    Code for you: 
    #!/usr/bin/perl ######################################
# Check installed CPAN modules for use of "use vars" #
# Because Perl 5.28.0 removes discouraged "use vars" #
# https://perlmonks.org/index.pl?node_id=1217408     #
######################################################

use strict;
use warnings;

use autodie;
use Config '%Config';
use ExtUtils::Installed;

for (split $Config{path_sep}, $ENV{PATH}) {
   $|++ if -x "$_/grep"
}
die "you need grep" unless $|;

my $t    = time;
my $m    = ExtUtils::Installed->new;
my @temp = $m->modules();
my @cpan = ();

for (@temp) {
    my @x = $m->files($_);
    push @cpan, @x;
}
@cpan = grep /site.*\.pm$/, @cpan;
my $opt = 0;

if (@ARGV) { $opt = 1 }
else {
print qq~Checking CPAN modules for "use vars" in Perl version $^V ~.
qq~(removed in Perl 5.28)\nhttps://metacpan.org/pod/release/XSAWYE~.
qq~RX/perl-5.28.0/pod/perldelta.pod#Removal-of-use-vars  \n(Invoke~.
qq~ with any arg to skip questions and generate a list of modules.) \n
+\n~;

print qq~The list may be big and printing progress makes it a bit slow
+er. 
Default: display progress, format output and print offending lines of 
code. Press return to start or n for no progress and list output. y/N~
+; 

chomp($opt = <STDIN>); $opt = 1 if $opt and lc $opt eq 'n';
}
my $INC = join '|', @INC;
my $n   = 0;
my $g   = 0;

for my $c (@cpan) {
   print "\rChecking: ","$n\tFound: $g\t" unless $opt;
   if (@_ = `grep 'use vars' $c`) {
      (my $f = $c) =~ s/($INC)//;
      $f =~ s,^/,,;
      $f =~ s,/,::,g;
      $f =~ s/\.pm$//;
      s/^\s+/  / for @_;
      $_{$f}=join"\n ",@_;
      $g++
   }
   $n++
}
if ($opt) {
   print "$_\n" for sort keys %_
}
else {
   $m = scalar keys %_;
   $t = time - $t;

   print qq~$m CPAN modules  (out of $n) found with "use vars"!\n~;
   print "$_:\n $_{$_}","-"x60,"\n" for sort keys %_;

   print qq~$m CPAN modules  (out of $n) found with "use vars"!\n~;
   print "That took $t secs (grep searched ",sprintf("%0d",$m/$t),
   " modules/second).\n";
}

    [download]
    Output: 
    
------------------------------------------------------------
XML::Twig:
 use vars qw($VERSION @ISA %valid_option);

 use vars qw( $weakrefs);

 use vars qw( %filter);
------------------------------------------------------------
XML::Twig::XPath:
 use vars qw($VERSION);
------------------------------------------------------------
YAPE::Regex:
 use vars '$VERSION';
------------------------------------------------------------
YAPE::Regex::Explain:
 use vars '$VERSION';
------------------------------------------------------------
905 CPAN modules  (out of 4918) found with "use vars"!
That took 31 secs (grep searched 29 modules/second).
    STOP REINVENTING WHEELS, START BUILDING SPACE ROCKETS!—CPAN 🐪
NES disassembly in perl6
1 direct reply — Read more / Contribute 		by holyghost
on Jun 25, 2018 at 02:58
    NES opcodes library 
    unit module dispelpotion;

### 6502 processor opcodes (Nintendo ES)

class NESopcodes {

        has %.nesopcodes;

        method BUILD() {

                self.buildtable();

                return %.nesopcodes;

        }

        method buildtable() {

                ### Everything is 2 bytes except where noted otherwise

                %.nesopcodes[0x69] = "ADC.1"; # immediate
                %.nesopcodes[0x65] = "ADC.2"; # zero page

                %.nesopcodes[0x29] = "AND.1"; # immediate
                %.nesopcodes[0x25] = "AND.2"; # zero page

                %.nesopcodes[0x0A] = "ASL.1"; # accumulator len 1
                %.nesopcodes[0x06] = "ASL.2"; # zero page

                %.nesopcodes[0x24] = "BIT.1"; # zero page
                %.nesopcodes[0x2C] = "BIT.2"; # absolute len 3

                %.nesopcodes[0x10] = "BPL"; # branch on plus
                %.nesopcodes[0x30] = "BMI"; # branch in minus
                %.nesopcodes[0x50] = "BVC"; # branch on overflow clear
                %.nesopcodes[0x70] = "BVS"; # branch on overflow set
                %.nesopcodes[0x90] = "BCC"; # branch on carry clear
                %.nesopcodes[0xB0] = "BCS"; # branch on carry set
                %.nesopcodes[0xD0] = "BNE"; # branch on neq
                %.nesopcodes[0xF0] = "BEQ"; # branch on eq

                %.nesopcodes[0x00] = "BRK"; # break

                %.nesopcodes[0xC9] = "CMP.1"; # immediate
                %.nesopcodes[0xC5] = "CMP.2"; # zero page

                %.nesopcodes[0xE0] = "CPX.1"; # immediate
                %.nesopcodes[0xE4] = "CPX.2"; # zero page

                %.nesopcodes[0xC0] = "CPY.1"; # immediate
                %.nesopcodes[0xC4] = "CPY.2"; # zero page

                %.nesopcodes[0xC6] = "DEC.1"; # immediate
                %.nesopcodes[0xD6] = "DEC.2"; # zero page

                %.nesopcodes[0x49] = "EOR.1"; # immediate
                %.nesopcodes[0x45] = "EOR.2"; # zero page

                %.nesopcodes[0x18] = "CLC"; # clear carry
                %.nesopcodes[0x38] = "SEC"; # set carry
                %.nesopcodes[0x58] = "CLI"; # clear interrupt
                %.nesopcodes[0x78] = "SEI"; # set interrupt
                %.nesopcodes[0xB8] = "CLV"; # clear overflow
                %.nesopcodes[0xD8] = "CLD"; # clear decimal
                %.nesopcodes[0xF8] = "SED"; # set decimal

                %.nesopcodes[0xE6] = "INC.1"; # immediate
                %.nesopcodes[0xF6] = "INC.2"; # zero page

                %.nesopcodes[0x4C] = "JMP.1"; # abs len 3
                %.nesopcodes[0x6C] = "JMP.2"; # indirect len 3

                %.nesopcodes[0x20] = "JSR"; # abs len 3

                %.nesopcodes[0xA9] = "LDA"; # immediate
                %.nesopcodes[0xA5] = "LDA"; # zero page

                %.nesopcodes[0xA2] = "LDX"; # immediate
                %.nesopcodes[0xA6] = "LDX"; # zero page

                %.nesopcodes[0xA0] = "LDY"; # immediate
                %.nesopcodes[0xA4] = "LDY"; # zero page

                %.nesopcodes[0x4A] = "LSR.1"; # accumulator len 1
                %.nesopcodes[0x46] = "LSR.2"; # zero page

                %.nesopcodes[0x86] = "STX.1"; # accumulator len 1
                %.nesopcodes[0x96] = "STX.2"; # zero page

                %.nesopcodes[0x84] = "STY.1"; # accumulator len 1
                %.nesopcodes[0x8C] = "STY.2"; # zero page

                %.nesopcodes[0x9A] = "STA.1"; # accumulator len 1
                %.nesopcodes[0xBA] = "STA.2"; # zero page

                ### Note padding and wrap around

        }

}

    [download]
    Note that there's not switch : 
    unit module dispelpotion;

class Disassembler {

        has %.nesopcodesmap;

        method BUILD() {

                my $nesopcodes = NESopcodes.new();
                %.nesopcodesmap = $nesopcodes.nesopcodes;



        }

        method disasm(@bytebuffer) {

                loop (my $i = 0; $i < length @bytebuffer; ) {

                        my $opcode = %.nesopcodesmap[@bytebuffer[$i]*1
+6+@bytebuffer[$i+1]]; 

                        if ($opcode) {

                                say $opcode + "\n";

                                if (not %.nesopcodesmap[@bytebuffer[$i
++2]*16+@bytebuffer[$i+3]]) {
                                        $i+=2;
                                }

                                if (not %.nesopcodesmap[@bytebuffer[$i
++4]*16+@bytebuffer[$i+5]]) {
                                        $i+=2;
                                }

                                if (not %.nesopcodesmap[@bytebuffer[$i
++6]*16+@bytebuffer[$i+7]]) {
                                        $i+=2;
                                }
                                $i += 2;
                        }
                }
        }



}

    [download]
List EXE_FILES installed by CPAN
2 direct replies — Read more / Contribute 		by usemodperl
on Jun 23, 2018 at 14:18
    EDIT: The original node was buggy so here's a fixed version that seems to show all the executables installed by CPAN! Original node below so I can be embarrassed forever.☺

    List EXE_FILES installed by CPAN: 
    #!/usr/bin/perl -l

use strict;
use warnings;

# List EXE_FILES installed by CPAN

$_ = join '', `perldoc -uT perllocal`;
@_ = (/EXE_FILES:\s([^>]+)/sg);
my @z = ();

for (@_) {
    my @x = split /\s+/;
    s/^\S+\///  for @x;
    push @z, @x;
}
%_ = map { $_ => 1 } @z;
print $_ for sort keys %_;
#print scalar keys %_;

    [download]
    List EXE_FILES installed by CPAN, by module: 
    #!/usr/bin/perl -l

use strict;
use warnings;

# List EXE_FILES installed by CPAN, by module

$_ = join '', `perldoc -uT perllocal`;
my @m = (/=head2.*?\|([^>]+)/g);
my @e = (/EXE_FILES:\s([^>]*)/sg);

for (my $c = 0; $c < scalar @m; $c++) {
   $_{$m[$c]} = $e[$c]
}

my @z = ();
my $n = 0;

for (sort { lc($a) cmp lc($b) } keys %_) {
   if (my @x = split /\s+/, $_{$_}) {
      print;
      $n += scalar @x;
      s/^\S+\///  for @x; 
      print " $_" for @x;
      print "";
   }
}
#print $n;

    [download]
    THE ORIGINAL NODE, DOES NOT WORK!:

    List EXE_FILES installed by CPAN: 
    perl -le'chomp(@_=`perldoc -T perllocal`);
# List EXE_FILES installed by CPAN
$_=join"\n",@_;@_=split/\"Module\"\s/;
@_=grep/EXE_FILES:\s[^"]+/,@_;for(@_){@x=split/\n/;
@x=grep/EXE|0m/,@x;push@z,@x}s/^\s+\*\s+\"([^\"]+).?/$1/ for@z;
@_=grep/EXE_FILES/,@z;@_=map{substr($_,11,length($_))}@_;undef@z;
for(@_){if(/\s/){@x=split/\s/;push@z,$_ for@x}else{push@z,$_}}
%_=map{s/^\S+\///;$_=>1}@z;print$_ for sort{lc($a)cmp lc($b)}keys%_'

    [download]


    List EXE_FILES installed by CPAN, by module: 
    perl -le'chomp(@_=`perldoc -T perllocal`);
# List EXE_FILES installed by CPAN, by module
$_=join"\n",@_; @_=split/\"Module\"\s/,$_;
@_=grep/EXE_FILES:\s[^"]+/,@_;for(@_){@x=split/\n/;
@x=grep/EXE_FILES|0m/,@x;push@z,@x}undef@x;
s/^\s+\*\s+\"([^\"]+).?/$1/ for@z;my$m;for(@z){
if(/EXE_FILES:\s(.*)/){$_{$m}=$1}else{$m=$_;$_{$m}=1}}
for(sort{lc($a)cmp lc($b)}keys %_){if($_{$_}=~/\s/){
@x=split/\s/,$_{$_};s/^\S+\/// for@x;$_{$_}=join"\n ",
@x}else{$_{$_}=~s/^\S+\///g}print"$_\n $_{$_}\n"}'

    [download]


    STOP REINVENTING WHEELS, START BUILDING SPACE ROCKETS!—CPAN 🐪
Apple Perl Quine
No replies — Read more | Post response 		by usemodperl
on Jun 19, 2018 at 22:09
    This perl code compiles and runs an apple mac app that decompiles and prints its own applescript source code: 
    perl -Mautodie -we '$app="ApplePerlQuine\@perlmonks.org.app";die"not a
+pple mac"unless${^O}eq"darwin";open$f,"|-","osacompile -o $app";print
+$f qq~set myPATH to path to me as string\nset myPATH to myPATH & "Con
+tents:Resources:Scripts:main.scpt"\nset myPATH to do shell script"ech
+o " & myPATH & " | tr : / | sed -E \x27s/Macintosh HD//\x27"\ndisplay
+ dialog (do shell script ("osadecompile " & myPATH)) with title "$app
+" buttons {"Use Perl!"} default button 1\n~;close$f;system("open $app
+")'

    [download]
    Read more... (5 kB)
Why is it so easy to make Perl apps for Apple Mac?
2 direct replies — Read more / Contribute 		by Anonymous Monk
on Jun 17, 2018 at 13:40
    Compile your Perl to a portable binary application for Apple Mac (99k): 
    
echo 'display alert (do shell script "perl -v")' | osacompile -o perl.
+app

    [download]
    Write apps for Apple Mac in Perl: Pt.1, Pt.2, Pt.3
How to write apps for macOS/OSX in Perl! Part 3: Random DNS Server
No replies — Read more | Post response 		by Anonymous Monk
on Jun 16, 2018 at 04:26
    Welcome to Part 3 of How to write apps for macOS/OSX in Perl! This app protects Internet Privacy by regularly changing DNS servers. It's designed to run constantly in the background. I use it all day every day for the past 2 months.

    This edition demonstrates how to:

    1. Write a very useful application!
    2. Use Perl to create, read and write a config file.
    3. Easily edit the config file.
    4. Configure multiple run time variables.
    5. Pass variables between Applescript and Perl.
    6. Handle errors and bad input.
    7. Use core Perl modules.

    See Part 1 to get started with Perl and the built-in Mac devtool Automator,
    and the demo Perl app for Mac: Perl ASN Check

    See Part 2 for more techniques to integrate Perl into Mac with Applescript,
    and the demo Perl app for Mac: Perl Version Tool

    This ~150 liner is ~120 lines of Applescript GUI logic linked to ~30 lines of core Perl code in the form of 3 one-liners! Hopefully our Mac-centric monks will pick up these techniques to write and share Mac apps to improve computing experiences with Perl! Remember: All Macs Have Perl!

      Compile this code with the instructions in Part 1
      to produce a 1.3MB portable binary application:

    Source: 

    -- Set random DNS server every n minutes.
# Demonstration Apple macOS/OSX app in AppleScript and Perl
# Posted to perlmonks.org by Anonymous Monk 6/16/2018
# Node: How to write apps for macOS/OSX in Perl! Part 3: Random DNS Se
+rver
-- Part 1: Perl ASN Check  https://perlmonks.org/?node_id=1216610
-- Part 2: Perl Version Tool https://perlmonks.org/?node_id=1216670

# DEFAULT DNS SERVERS:
# 1.1.1.1 = Cloudflare
# 8.8.8.8 = Google
# 45.77.165.194 = Fourth Estate Zero Knowledge

set DNS to "1.1.1.1
8.8.8.8
45.77.165.194"

set DEFAULT_NETWORK to "Wi-Fi"
set TITLE to "Random DNS Server"

# CREATE AND/OR READ CONFIGURATION FILE:
# 1. PASS APPLESCRIPT VARIABLES TO PERL ->
# 2. SEND PERL VARIABLES TO APPLESCRIPT <-
# 3. AND THAT LAST LINE...
try
    set INI to do shell script "printf $HOME" & "/.dns.random.config"
    set CFG to do shell script "
        perl -Mautodie -we ' 
            my $config = qq~" & INI & "~;
            if (-e $config) {
                open my $fh, q~<~, $config;
                @_ = <$fh>; close $fh;
                @_ = grep /\\S+/, @_;
                print @_;
            } else {
                open my $fh, q~>~, $config;
                print $fh qq~" & DNS & "~; close $fh;
                print qq~" & DNS & "~;
            }
        '
    "
on error oops
    display alert oops as critical
end try
set DNS to CFG

# RUNTIME CONFIG LOOP
repeat
    try
        set TXT to "DNS Servers:

" & DNS & "
        
Minutes between change? (blank to exit)"
        
        set EAE to "EXIT AND EDIT CONFIG"
        # GET DIALOG OBJECT CONTAINING INPUT AND CLICKED BUTTON VALUE
        set DUR to display dialog TXT with title TITLE default answer 
+"" buttons {EAE, "OK"} default button 2
        set DUR_text to text returned of DUR as number
        set DUR_button to button returned of DUR
        
        if DUR_button is EAE then # EDIT CONFIG
            try
                do shell script "open -a TextEdit " & INI & ""
                return # EXIT
                
            on error oops
                display alert oops as critical
                return # EXIT
            end try
        end if
        
        if DUR_text is 0 then return # EXIT
        
        set DUR to DUR_text
        set NETS to do shell script "networksetup -listallnetworkservi
+ces"
        set TXT to "Network Interfaces:
        
" & NETS & "

Network?"
        
        set NETWORK to text returned of (display dialog TXT with title
+ TITLE default answer DEFAULT_NETWORK buttons {"OK"} default button 1
+)
        try
            # DOES NETWORK EXIST?
            set hmm to do shell script "
                perl -we '
                    @_ = qx/networksetup -getinfo " & NETWORK & "/;
                    $_ = join qq~\\n~, @_;
                    print /Error/ ? 0 : 1;
                '
            "
        on error oops
            display alert oops as critical
            return # EXIT
        end try
        
        if hmm as number is equal to 0 then
            display notification "Network not found! Exit..." with tit
+le TITLE
            return # EXIT
        end if
        
        exit repeat # EXIT CONFIG LOOP
        
    on error oops
        display notification "This shouldn't happen!" with title TITLE
        return # EXIT
    end try
end repeat # END CONFIG LOOP

set MSG to button returned of (display dialog "Notification of change?
+" buttons {"No", "Yes"} default button 2)
# END CONFIG

# MAIN EVENT LOOP
repeat
    try
        # Use perl to read last line of resolv.conf as current DNS ser
+ver.
        # Exclude current server and shuffle list to get new value.
        # Set new server and return the old and new values to applescr
+ipt.
        set PERL to do shell script "
            perl -MList::Util=shuffle -Mautodie -we '
                open my $fh, q~<~, q~/private/etc/resolv.conf~;
                chomp(@_ = <$fh>);
                close $fh;
                
                $_ = pop @_;    
                my (undef,$cur) = split q~ ~;
                
                $_ =  qq~" & DNS & "~;
                @_ = split /\\s+/;
                @_ = grep !/$cur/, @_;
                @_ = shuffle @_;
                
                my $new = pop @_;
                system(qq~networksetup -setdnsservers " & NETWORK & " 
+$new~);
                print qq~$cur $new~;
            '
        "
    on error oops
        display alert oops as critical
    end try
    
    # AN APPLESCRIPT SPLIT
    set text item delimiters to {" "}
    set {CUR, NEW} to text items 1 thru 2 of PERL
    
    if MSG is "Yes" then
        display notification "DNS changed from " & CUR & " to " & NEW 
+with title TITLE
    end if
    
    delay ((DUR as integer) * 60)
end repeat

# MADE IN USA (This program, Perl, Apple, Me!)
# b9ce5dcd671f9647fb86a6f3709a572ffd6e2aa490c005300585a555fabf9ce8
# 060c38ad8715a6a2381cc653ad5a7dd1815f3cf990c31594b4a1b20ef4fc9d27

    [download]
How to write apps for macOS/OSX in Perl! Part 2
No replies — Read more | Post response 		by Anonymous Monk
on Jun 14, 2018 at 17:00
    Welcome to Part 2 of How to write apps for macOS/OSX in Perl! See Part 1 to get started with the built-in macOS devtool Automator. This edition demonstrates how to:

    • Process choices with Perl from an Applescript dialog to:
      1. Display output from Perl to an Applescript dialog.
      2. Execute Perl in Terminal to display its output.
      3. Send output from Perl to an application (TextExit).
    Applescript is to the operating system what Javascript is the the web browser. It can do many things and what it can't do can always be handled by shell commands and especially Perl! When the code below is saved by Automator as something like PerlVersionTool.app you will have a 1.3MB portable binary application! Double click and ENJOY!
    • Other techniques covered here include:
      1. Visiting websites (Perlmonks of course!)
      2. Displaying notifications
      3. Application control
      4. Applescript subroutines
      5. Abusing buttons to widen dialogs
      6. How to rule your world with Perl!
    Source: 
    (* Demonstration macOS/OSX app in AppleScript and Perl   *)
(* Posted to perlmonks.org by Anonymous Monk 6/14/2018   *)
(* Node: How to write apps for macOS/OSX in Perl! Part 2 *)

set TITLE to "Perl Version Tool"
set PROMPT to "Make a selection"
set _1 to "Perl version, patchlevel and license"
set _2 to "Perl configuration summary"
set _3 to "Perl command line help"
set _4 to "Visit Perlmonks.org!"

repeat
    set what to choose from list {_1, _2, _3, _4} with title TITLE wit
+h prompt PROMPT OK button name {"View"} cancel button name {"Exit"} d
+efault items _1
    set what to what as string
    
    if what is _1 then
        set CMD to "perl -v" # ONE LINERS OR PROGRAMS OF ANY SIZE!
        
    else if what is _2 then
        set CMD to "perl -V"
        
    else if what is _3 then
        set CMD to "perl -h"
        
    else if what is _4 then
        display notification "Opening The Monastery Gates!"
        set CMD to "open https://perlmonks.org"
        
    else if what is "false" then
        return # EXIT
        
    end if
    
    if what is _2 then
        # SEND PERL CODE TO TERMINAL AND EXECUTE
        doShell(CMD)
    else if what is _3 then
        # CAPTURE PERL STDOUT
        set CMD to do shell script CMD
        # SEND PERL STDOUT TO TEXTEDIT
        textEdit(CMD)
    else
        # CAPTURE PERL STDOUT
        set RES to do shell script CMD
        # MAKE DIALOG WIDE
        set SPC to "                                                  
+          "
        # PRINT PERL STDOUT TO APPLESCRIPT ALERT
        display alert TITLE message RES buttons {SPC & "Cool" & SPC} d
+efault button 1
    end if
end repeat

# APPLESCRIPT SUBS:

on doShell(CMD)
    try
        tell application "Terminal"
            activate
            tell application "System Events" to keystroke "n" using {c
+ommand down}
        end tell
        
        tell application "System Events"
            tell application process "Terminal"
                set frontmost to true
                keystroke CMD
                keystroke return
            end tell
        end tell
    on error oops
        display alert oops as critical
    end try
end doShell

on textEdit(CMD)
    try
        tell application "TextEdit"
            activate
            tell application "System Events" to keystroke "n" using {c
+ommand down}
        end tell
        
        tell application "System Events"
            tell application process "TextEdit"
                set frontmost to true
                keystroke CMD
            end tell
        end tell
    on error oops
        display alert oops as critical
    end try
end textEdit

    [download]
How to write apps for macOS/OSX in Perl!
3 direct replies — Read more / Contribute 		by Anonymous Monk
on Jun 14, 2018 at 02:25
    macOS/OSX comes with tools that make it super easy to write native GUI applications with Applescript and Perl! This example uses the cool and free Robtex API to validate Autonomous System Numbers for networks in the global BGP table. Applescript provides plenty of ways to collect and display data, handle errors, and can launch terminals and text editors or any app and automate the entire operating system GUI while Perl does pretty much anything else you can imagine.

    Start : Applications -> Automator
    Select: File -> New
    Select: Application

    We're going to create an application but Automator can also encapsulate Perl into a Service, Image Capture Plugin, Dictation Command, Folder Action, Calendar Alarm, Print Plugin or Workflow.

    Now that Automator is open click the Library icon or select View -> Show Library.

    Select: Actions -> Utilities -> Run AppleScript (double click it)

    Replace the default code with this: 

    (* Demonstration MacOS/OSX app in AppleScript and Perl *)
(* Posted at perlmonks.org by Anonymous Monk 6/13/2018 *)
(* Node: How to write apps for macOS/OSX in Perl!      *)

repeat
    repeat
        try
            set ASN to text returned of (display dialog "Autonomous Sy
+stem Number:
(Example: 714 is Apple Inc. 666 does not exist. Blank to exit.)" with 
+title "Perl ASN Check" default answer "" buttons {"Check"} default bu
+tton 1)
            set ASN to ASN as number # require a number
            exit repeat # continue if ASN is numeric
        on error # not a number?
            display alert "Please enter an Autonomous System Number!" 
+as critical
        end try
    end repeat
    
    if ASN is equal to 0 then return # exit if blank
    
    # ALL MACS HAVE PERL BABY!
    set RES to do shell script "
        perl -MHTTP::Tiny -e '
            my $r = HTTP::Tiny->new->get(q~https://freeapi.robtex.com/
+asquery/" & ASN & "~);
            if (length $r->{content}) {
                $r->{content} =~ /[0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+/
                ? print q~ASN Exists!~ : print q~ASN Not Found!~;
            }
            else {
                print q~Download failed!~
            }
        '
    "
    display alert RES
end repeat

    [download]

    Save the application and double click its icon in finder. BEHOLD! Perl apps for macOS/OSX!!!

    (Tips: In the Perl code avoid single quotes and be prepared to do some extra backslashing.)
perlpdf for perldoc as PDF
1 direct reply — Read more / Contribute 		by Anonymous Monk
on Jun 02, 2018 at 05:40
    Type perlpdf instead of perldoc!

    This bash function uses pod2pdf to produce a very nice san-serif font PDF with title and footer and opens it with the "open" command (for OSX, adjust as needed). The tempfile is necessary for the PDF reader (Preview) to have a filename should one choose to save the file as, for example: "perldoc -q array.pdf". pod2pdf seems to call PDF::API2 about 10,000 times per page so it's slow on large documents 

    function perlpdf() {
    P=perldoc; 
    X="$P $@"; 
    $P -uT "$@" | 
    pod2pdf --title="$X" --footer-text="$X" > "/tmp/$X.pdf"; 
    open "/tmp/$X.pdf"; 
}

    [download]
    Type perlpdx instead of perlpdf!

    This one uses ghostscript ps2pdf via man via pod2man to produce a plainer looking serif font PDF with a more generic title and footer (perl version/date/etc) and a filename. It seems more complicated but the process is extremely fast. 

    function perlpdx(){
    P=perldoc;
    $P -uT "$@" |
    pod2man > "/tmp/$P $*.1";
    man -t "/tmp/$P $*.1" |
    ps2pdf - "/tmp/$P $*.pdf";
    open "/tmp/$P $*.pdf";
}

    [download]
Safely read/write a file simultaneously
1 direct reply — Read more / Contribute 		by golux
on May 16, 2018 at 20:40
    I'm working on a Client/Server project where a "progress file" gets updated (potentially quite often) and read from a separate (CGI) process. I was pretty sure having the writer reopening the progress file could cause the reader to have occasional problems, and also fairly sure that writing to a tempfile instead (and then moving the tempfile over the progress file) would be much safer (ie. atomic).

    But why Google it when you can write code to test it instead? ;-)

    Here's the result, which indicates I was correct on both counts, and happily the latter seems to be atomic enough that an error never occurs. Set or clear the value of $unsafe to try the different algorithms. 

    #!/usr/bin/perl

###############
## Libraries ##
###############
use strict;
use warnings;
use File::Copy;
use Function::Parameters;
use IO::File;


##################
## User-defined ##
##################
my $file   = 'file.txt';
my $rdelay = 0.03;      # Read delay:  3/100th of a second
my $wdelay = 0.01;      # Write delay: 1/100th of a second
my $unsafe = 1;         # Set to zero to call the "safe" write algorit
+hm


##################
## Main Program ##
##################
$| = 1;

if (fork) {
    writer($unsafe);
} else {
    reader();
}


#################
## Subroutines ##
#################

#
# Writes to a file many times per second.
#
fun writer($unsafe) {
    my $count = 0;
    while (1) {
        if ($unsafe) {
            writefile1($file, $count++);
        } else {
            writefile2($file, $count++);
        }

        # Sleep for 1/100th of a second
        select(undef, undef, undef, $wdelay);
    }
}


#
# Reads from the file, displaying number of total errors
# (each time the $count was undefined).
#
fun reader() {
    sleep 1;        # Give the writer time to create the file initiall
+y
    my $nerrs = 0;  # How many total errors did we get?

    while (1) {
        my $count = readfile($file);
        if ($count) {
            printf "%8d, ", $count;
        } else {
            printf "\nTotal errors = %d\n", ++$nerrs;
            sleep 1;
        }
    }

    select(undef, undef, undef, $rdelay);
}


#
# Algorithm 1
#
# Writes the $value directly to the file
# This turns out to be quite prone to error when the file is read.
#
fun writefile1($file, $value) {
    my $fh = IO::File->new;
    open($fh, '>', $file) or die "Can't write '$file' ($!)\n";
    print $fh "$value\n";
    close($fh);
}


#
# Algorithm 2
#
# Writes the $value to a temp file, then moves the tempfile over the
# actual destination.  This turns out to be quite safe for reading.
#
fun writefile2($file, $value) {
    my $fh = IO::File->new;
    my $tmp = 'tmp.txt';
    open($fh, '>', $tmp) or die "Can't write '$file' ($!)\n";
    print $fh "$value\n";
    close($fh);
    move($tmp, $file);
}


#
# Reads the $value from the $file
#
fun readfile($file) {
    my $fh = IO::File->new;
    open($fh, '<', $file) or die "Can't read '$file' ($!)\n";
    my $value = <$fh>;
    defined($value) or return 0;
    chomp($value);
    close($fh);
    return $value;
}

    [download]
    say  substr+lc crypt(qw $i3 SI$),4,5
Conways Game of Life in PDL
2 direct replies — Read more / Contribute 		by mxb
on May 16, 2018 at 11:31

    Edit: Apparently this is in the PDL Documentation, as an example. Whoops! Still, it was a good learning exercise :)

    Rather than a ported numpy tutorial, this is a self developed implementation of Conways Game of Life written in Perl/PDL. Hopefully people find this interesting as I feel it shows how concise PDL code can be.

    The code is fairly straightforward. There is a single function conway() which accepts a single argument of the game arena. This is a two dimensional PDL matrix. Alive cells are represented by a one, dead ones by zero. The conway() function sums the value of each cell along with value of its nine neighbours into a temporary variable $tmp. It then applies the rules of the game, which are:

    • Any live cell with fewer than two live neighbors dies, as if caused by under population.
    • Any live cell with two or three live neighbors lives on to the next generation.
    • Any live cell with more than three live neighbors dies, as if by overpopulation.
    • Any dead cell with exactly three live neighbors becomes a live cell, as if by reproduction.

    This is implemented as an elementwise or and an elementwise and.

    The main loop of the game is in the body of the code and simply displays the generation and the game arena and awaits input

    The game arena is initialised with a 'glider', but feel free to experiment. As PDL wraps around by default, the surface is that of a torus.

    Enter a blank line for the next generation, anything else to exit

    Enjoy

    #!/usr/bin/env perl
use strict;
use warnings;
use 5.016;

use PDL;

sub conway {
    my $pdl = shift;
    die "Not 2D piddle" unless $pdl->ndims == 2;

    # Add up all values:
    my $tmp = $pdl +                                       # original
      $pdl->transpose->rotate(-1)->transpose +             # north
      $pdl->transpose->rotate(-1)->transpose->rotate(-1) + # northeast
      $pdl->rotate(-1) +                                   # east
      $pdl->transpose->rotate(1)->transpose->rotate(-1) +  # southeast
      $pdl->transpose->rotate(1)->transpose +              # south
      $pdl->transpose->rotate(1)->transpose->rotate(1) +   # southwest
      $pdl->rotate(1) +                                    # west
      $pdl->transpose->rotate(-1)->transpose->rotate(1);   # northwest

    # Cell is alive if it's either:
    return ( $tmp == 4 & $pdl == 1 ) |    # Alive +3 neighbors
      $tmp == 3;    #  Alive +2 neighbors or dead +3 neighbors
}

my $arena = pdl(byte,
    [
        [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ],
        [ 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ],
        [ 0, 1, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ],
        [ 0, 0, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ],
        [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ],
        [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ],
        [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ],
        [ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ],
    ]
);

my $gen = 0;
while (1) {
    print "Generation: $gen (press enter for next)\n";
    print $arena;
    $arena = conway($arena);
    $gen++;
    exit if <STDIN> ne "\n";
}

    [download]
Basic Neural Network in PDL
1 direct reply — Read more / Contribute 		by mxb
on May 15, 2018 at 07:37

    As part of my ongoing quest to port tutorials from Python/numpy to Perl/PDL please graciously accept the following contribution to the Monastery.

    This is the Perl/PDL port of A Neural Network in 11 Lines of Python. While I've added some documentation, please reference the original blog post for full details.

    #!/usr/bin/env perl
use strict;
use warnings;
use 5.016;

use PDL;

######################################################################
# This example is ported from the tutorial at
# https://iamtrask.github.io/2015/07/12/basic-python-network/
######################################################################
#
# In this example, we are training a neural network of two layers
# (one set of weights).
# It has the following variables:
#   $X        - input neurons
#   $y      - desired output values
#   $syn0   - single layer of weights
#   $l1     - output neurons
#

# This is our 'non-linear' function. It accepts two arguments.
# The first argument is a piddle of values, and the second argument
# is a flag.
#
# If the flag is unset, the function returns the elementwise Sigmoid
# Function (https://en.wikipedia.org/wiki/Sigmoid_function).
#
# If the flag is set, the function returns the elementwise derivative
# of the Sigmoid Function.
sub nonlin {
    my ( $x, $deriv ) = @_;
    return $x * ( 1 - $x ) if defined $deriv;
    return 1 / ( 1 + exp( -$x ) );
}

# $X is are our input values. It contains four examples of three
# inputs. It is the following matrix:
#
# [
#  [0 0 1]
#  [0 1 1]
#  [1 0 1]
#  [1 1 1]
# ]
my $X = pdl( [ [ 0, 0, 1 ], [ 0, 1, 1 ], [ 1, 0, 1 ],
    [ 1, 1, 1 ] ] );

# $y is the output vector. It is the following desired outputs for
# the four input vectors above:
# [0 0 1 1]
my $y = pdl( [ 0, 0, 1, 1 ] )->transpose;

# $syn0 is the first layer of weights, connecting the input values
# ($X) to our first layer ($l1). It is initialised to random values
# between -1 and 1.
my $syn0 = ( ( 2 * random( 3, 1 ) ) - 1 )->transpose;

# $l1 is the second (output) layer:
my $l1;

# This is the training loop. It performs 10000 training interations.
for ( 0 .. 10000 ) {

    # Predict the outputs for all four examples (full batch training)
    # This is performed by applying the non-linear function
    # elementwise over the dot product of our input examples matrix
    # ($X) and our weights between layers 0 (input) and 1 (output)
    # ($syn0):
    $l1 = nonlin( $X x $syn0 );

    # Calculate the error by comparing calculated values ($l1) to
    # known output values ($y)
    my $l1_error = $y - $l1;

    # Calculate the 'error weighted derivative'. This is the
    # elementwise product of the errors and the derivative of the
    # non-linear function across the outputs
    my $l1_delta = $l1_error * nonlin( $l1, 1 );

    # Update the weights between the layers
    $syn0 += ( $X->transpose x $l1_delta );
}

# Display output
say "Expected output:", $y; 
say "Output After Training:", $l1;

    [download]

    Running it on my machine takes approximately 1.5 seconds and gives output similar to:

    % perl nn_tutorial.pl
Expected output:
[
 [0]
 [0]
 [1]
 [1]
]

Output After Training:
[
 [0.0096660515]
 [0.0078649669]
 [  0.99358927]
 [  0.99211856]
]

    [download]
Locate Survey Markers (US-Only, uses USGS WebService)
No replies — Read more | Post response 		by roboticus
on May 04, 2018 at 18:38

    Hello, all--

    I had a friend who wanted to find some survey markers near his house, so I looked around and found a webservice that would locate some survey markers in an area. Since I coded it up, I thought I'd publish it here, in case there's anyone else who might like to try it. It's rough (as it's a one-off), but should be easy enough to modify.

    As is often the case, all the heavy lifting is done by some handy CPAN modules (JSON, HTTP::Request, LWP::UserAgent and Math::Trig). I was especially pleased to find Math::Trig--I was trying to derive it myself and needed arc-cosine. When I found Math::Trig had acos and looked over the docs, I found that it already had all the great-circle math as well!

    Anyway, I hope someone finds it useful...

    #!env perl
#
# websvc_usgs_fetch_bounding_box.pl  <LAT> <LON> <dist>
#
# Use the USGS "Bounding Box Service" to find survey markes within the
# rough rectangle whose sides are <dist> miles from the specified lati
+tude
# and longitude.
#
# 20180504 original version
#
use strict;
use warnings;
use Data::Dump 'pp';
use HTTP::Request;
use JSON;
use LWP::UserAgent;
use Math::Trig qw( :great_circle deg2rad );

my $LAT = shift;
my $LON = shift;
my $center_dec = [ $LON, $LAT ];
my $squaradius_mi = shift or die <<EOMSG;
Expected:
perl websvc_usgs_fetch_bounding_box.pl LAT LON RAD

    LAT - latitude like 38.1234,
    LON - longitude like -78.1234,
    RAD - radius in miles (actually roughly a rectangle rather than ci
+rcle)
EOMSG

my $Re_mi = 3958.8; # radius of earth in miles

# Figure how approximately how long a degree is in both the longitudin
+al and
# latitudinal directions.
my $mi_per_degree = miles_per_degree([ NESW($LON, $LAT) ]);

# Now find the (min/max) * (lat,lon) for the bounding rectangle to sea
+rch
# for survey markers
my $deg_per_mi_lat = 1 / $mi_per_degree->[1];
my $deg_per_mi_lon = 1 / $mi_per_degree->[0];

my $min_lat = $center_dec->[1] - $squaradius_mi*$deg_per_mi_lat;
my $max_lat = $center_dec->[1] + $squaradius_mi*$deg_per_mi_lat;
my $min_lon = $center_dec->[0] - $squaradius_mi*$deg_per_mi_lat;
my $max_lon = $center_dec->[0] + $squaradius_mi*$deg_per_mi_lat;

# We'll use the DDMMSS format for the lat/lon
$min_lat = dec_to_DDMMSS($min_lat, "N", "S");
$max_lat = dec_to_DDMMSS($max_lat, "N", "S");
$min_lon = dec_to_DDMMSS($min_lon, "E", "W");
$max_lon = dec_to_DDMMSS($max_lon, "E", "W");

# Now fetch the data, and print the results
my $URL = "http://geodesy.noaa.gov/api/nde/bounds?"
    ."minlat=$min_lat&maxlat=$max_lat"
    ."&minlon=$min_lon&maxlon=$max_lon";

my $request = HTTP::Request->new(GET=>$URL, [ 'Content-Type'=>'applica
+tion/json; charset=UTF-8' ]);
my $ua = LWP::UserAgent->new;
my $response = $ua->request($request);

if (! exists $response->{_content}) {
    # crappy error detection/handling but it meets my current needs
    print pp($response), "\n";
    print "***** expected response->{content}!!!!!!!!\n";
}

my $r = decode_json($response->{_content});

print "Found ", scalar(@$r), " markers within $squaradius_mi miles cen
+tered around ",
      pp($center_dec), "\n";

print <<EOHDR;
LATITUDE   LONGITUDE  NAME                 PID
---------- ---------- -------------------- ----------
EOHDR
for my $hr (@$r) {
    printf "%-10s %-10s %-20s %-10s\n", $hr->{lat}, $hr->{lon}, $hr->{
+name}, $hr->{pid};
}

sub dec_to_DDMMSS {
    my ($dec, $dir_pos, $dir_neg) = @_;

    # Unfortunately, they use 2 sig digs for N/S and 3 for E/W
    my $fmt = $dir_pos eq 'N' ? "%s%02d%02d%02d.%03d" : "%s%03d%02d%02
+d.%03d";

    my $dir = $dir_pos;
    if ($dec < 0) { $dec = -$dec; $dir = $dir_neg; }

    my ($deg, $min, $sec, $sfrac) = (int($dec), 0, 0, 0);

    $dec = 60 * ($dec - $deg);
    $min = int($dec);
    $dec = 60 * ($dec - $min);
    $sec = int($dec);
    $sfrac = int(1000*($dec-$sec));

    return sprintf $fmt, $dir, $deg, $min, $sec, $sfrac;
}

sub dms_to_DDMMSS {
    my $dms = shift;
    my ($deg, $dir, $min, $sec, $sfrac);
    if ($dms =~ /^\s*(\d+)\s*([NEWS])\s*(\d+)\s*'\s*([\d\.]+)\s*"\s*$/
+) {
        ($deg, $dir, $min, $sec, $sfrac) = ($1, $2, $3, $4, 0);
        if ($sec =~ /(\d+)\.(\d+)/) {
            ($sec,$sfrac) = ($1,$2);
        }
    }
    else {
        die "Unexpected format <$dms>!";
    }

    # Build the return value: For N/S use <xDDMMSS.s*>, for E/W use <x
+DDDMMSS.s*>
    if ($dir eq "N" or $dir eq "S") {
        return sprintf "%s%02d%02d%02d.%s", $dir, $deg, $min, $sec, $s
+frac;
    }
    else {
        return sprintf "%s%03d%02d%02d.%s", $dir, $deg, $min, $sec, $s
+frac;
    }
}

sub NESW { deg2rad($_[0]), deg2rad(90-$_[1]) }

sub dms_to_dec {
    my $dms = shift;
    my ($deg, $dir, $min, $sec, $sfrac);

    if ($dms =~ /^\s*(\d+)\s*([NEWS])\s*(\d+)\s*'\s*([\d\.]+)\s*"\s*$/
+) {
        ($deg, $dir, $min, $sec, $sfrac) = ($1, $2, $3, $4, 0);
        if ($sec =~ /(\d+)\.(\d+)/) {
            ($sec,$sfrac) = ($1,$2);
        }
    }
    else {
        die "Unexpected format <$dms>!";
    }

    $dir = ($dir eq 'N' or $dir eq 'E') ? 1 : -1;
    return $dir * ($deg + $min/60.0 + (0 + ("$sec.$sfrac"))/3600.0);
}

# compute number of miles per degree at the specified lat/lon
sub miles_per_degree {
    my $news = shift;

    my $news_1lat = [ @$news ];
    $news_1lat->[1] += deg2rad(1.0);

    my $news_1lon = [ @$news ];
    $news_1lon->[0] += deg2rad(1.0);

    my $dLat_km = great_circle_distance(@$news, @$news_1lat, $Re_mi);
    my $dLon_km = great_circle_distance(@$news, @$news_1lon, $Re_mi);

    return [ $dLat_km, $dLon_km ];
}

    [download]

    A sample run gives me:

    $ perl websvc_usgs_fetch_bounding_box.pl 34.1234 -78.1234 1.5
Found 11 markers within 1.5 miles centered around [-78.1234, 34.1234]
LATITUDE   LONGITUDE  NAME                 PID
---------- ---------- -------------------- ----------
34.14829   -78.09827  WINNABOW RM 4        EB0192
34.14832   -78.09805  WINNABOW             EB0189
34.14856   -78.09788  WINNABOW RM 3        EB0191
34.09944   -78.12361  P 117                EB0198
34.11095   -78.11490  FLOWERS              EB2124
34.11178   -78.11387  Q 117                EB0197
34.11812   -78.10776  BECK                 EB2125
34.12278   -78.10611  R 117                EB0195
34.12708   -78.10360  CAMPBELL             EB2108
34.14593   -78.10423  WINNABOW AZ MK 2     EB1389
34.14722   -78.11694  N 235                EB0300

    [download]

    ...roboticus

    When your only tool is a hammer, all problems look like your thumb.
<Newer entries  (196-210) of 300 Older entries> 

Add your CUFP
Title:
CUFP:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":

  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.