This section is the place to post your general code offerings -- everything from one-liners to full-blown frameworks and apps.

CUFP's
SDBM databases: Alternate Keys with Duplicates
1 direct reply — Read more / Contribute
by erichansen1836
on Oct 22, 2017 at 14:39

    Perl SDBM databases of key/value pairs (tied to program hash tables) can hold/house multiple format KEYS - which is convenient for persistent random access indexing to Flat File database records. <Note: The VALUE in the KEY/VALUE pairs is used to store the byte offsets of the Flat File records indexed>. For EXAMPLE... If you have a Flat File database (of millions of records) having the fixed-length records, random access indexed, by Social Security Number (UNIQUE PRIMARY KEY), you may also wish to have an ALTERNATE KEY WITH DUPLICATES too, in case the Social Security Number is not known for Look Up. The below code snippet (incomplete, used just to illustrate a methodology) shows how this may be accomplished to setup the indexing. Once the indexing is setup, you can use a FOR LOOP iterated from: 1 to $NUM_RECS, to random access retrieve all the Flat File database records matching any arbitrary compound KEY, composed of info contained with the fields of the records. Note: The FILE POINTER is set to any record byte offset before performing READ/WRITE operations. This is ISAM(Indexed Sequential Access Method), NoSQL, Embedded database technology. This indexing stays persistent, so that Lookup is immediately available every time you launch your database user-interface (or batch) application program. SDBM is in the public domain, so you can distribute your FlatFile/SDBM database files and Perl Application Code, FREE of CHARGE to as many companies and end-users as you like. For more discussion and Perl code examples at Perl Monks, see "JOINT DATABASE TECHNOLOGY" thread.

    #-- YYYYMMDD #-- Key example: BirthDate|LastNameFirst4Chars|FirstNameInitia +l|StateCode #-- "19591219|Will|K|TX" #-- $KEY without a Seq Nbr is used to increment the number of rec +ords saved to the database #-- having a particular ALT KEY w/DUPS - in this example: "1959 +1219|Will|K|TX" $KEY=$BirthDate . "|" . $LastNameFirst4Chars . "|" . $FirstNameIn +itial . "|" . $StateCode; $Hash{$KEY}=0; #-- Now index the first record encountered in the Flat File datab +ase with this particular ALT KEY w/DUPS $num_recs = $Hash{$KEY}; $num_recs++; #-- i.e. one(1) $Hash{$KEY}=$num_recs; $newKEY=$KEY . "|" . $num_recs; #-- produces: "19591219|Will|K|TX|1" $Hash{$newKEY}= #-- The VALUE would be set to the byte offset o +f the Flat File record just indexed #-- Now index the second record encountered in the Flat File data +base with this particular ALT KEY w/DUPS $num_recs = $Hash{$KEY}; $num_recs++; #-- i.e. two(2) $Hash{$KEY}=$num_recs; $newKEY=$KEY . "|" . $num_recs; #-- produces: "19591219|Will|K|TX|2" $Hash{$newKEY}= #-- The VALUE would be set to the byte offset o +f the Flat File record just indexed #-- and so on...
Determining Gaps and Overlap in Timestamped Data
No replies — Read more | Post response
by haukex
on Oct 20, 2017 at 11:16

    I've recently been working with large sets of timestamped measurement data from different devices, often recorded at different times on different days and spread across multiple files. Since I'm not always involved in the recording of the data, I need to look at when the devices were turned on and off, any gaps in the data, etc., in particular for which spans of time all devices were measuring at the same time, since that's the data that then needs to be analyzed. The timestamps are jittery, and data doesn't always come in order (or, equivalently, I'd like to not have to sort everything by timestamp). Set::IntSpan's union and intersect operations make this pretty easy!

Finding matching filenames in a directory tree [mz2255]
No replies — Read more | Post response
by 1nickt
on Oct 19, 2017 at 15:01

    Earlier today a new monk (mz2255) attempted to post a question on SoPW about recursively searching for files in a directory tree. He was having issues with excluding . and .. and also with rel2abs and nested readdir calls and what have you. He was unable to get the SoPW to post and ended up posting on his scratch pad, so here is a reply for mz2255, and a demonstration of what I would call the modern way to do the job, using Path::Tiny.

    Note that the regexp is minimally modified from the OP and likely needs improvement before it can be used reliably for the OP's desired outcome. Left here for demo purposes.

    use strict; use warnings; use feature qw/ say /; use Data::Dumper; $Data::Dumper::Sortkeys = 1; use Path::Tiny; my $root_dir = Path::Tiny->tempdir; _populate_for_demo( $root_dir ); my $re = qr/ (?:\w|\d)+ _ \w+ _ .+ _R(1|2)_ .+ /x; my %results; $root_dir->visit( sub { $_->is_file and push @{ $results{$1} }, "$_" if /$re/ }, { recurse => 1 }, ); say Dumper \%results; exit; sub _populate_for_demo { my $temp_dir = shift; path("$temp_dir/$_/aa_bb_cc_R1_dd.tmp")->touchpath for 'foo','bar' +; path("$temp_dir/$_/aa_bb_cc_R2_dd.tmp")->touchpath for 'baz','qux' +; return $temp_dir; } __END__
    Output:
    $ perl 1201682.pl $VAR1 = { '1' => [ '/tmp/0JbuMoAJix/bar/aa_bb_cc_R1_dd.tmp', '/tmp/0JbuMoAJix/foo/aa_bb_cc_R1_dd.tmp' ], '2' => [ '/tmp/0JbuMoAJix/baz/aa_bb_cc_R2_dd.tmp', '/tmp/0JbuMoAJix/qux/aa_bb_cc_R2_dd.tmp' ] };

    Update: moved creation of the temp dir to main for clarity


    The way forward always starts with a minimal test.
HollyGame gamekit (almost @ CPAN)
2 direct replies — Read more / Contribute
by holyghost
on Oct 15, 2017 at 04:22
    This is the first implmentation of HollyGame, it is a framework underneath e.g. SDL 1.2 in my code or or buildable with SDL 1.2 or cairo 1.2 or 2.x. If I debug it, it will try to host it on CPAN

    Now follows an implementation of the game Wycadia based on the above code :

Unidatab-CGI reloaded
1 direct reply — Read more / Contribute
by emilbarton
on Oct 13, 2017 at 04:07
Indexed Flat File databases (for ISAM, NoSQL, Perl Embedded databases)
1 direct reply — Read more / Contribute
by erichansen1836
on Oct 08, 2017 at 11:13

    TOPIC: FAST!! Random Access Indexed, Relational Flat File Databases, Indexed by external Perl SDBM databases of key/value pairs tied to program "in memory" hash tables, where the Key in the Key/Value Pair is one or more fields and/or partial fields concatenated together (separated by a delimiter such as a pipe "|") and contained within the Flat File records for you to arbitrarily seek to a single record or a sorted/related group of records within your database.

    Since it has been over 2 years ago since I first posted about this TOPIC I discovered, I wanted to alert the Perl community to the original thread where you can find Perl source code now for examples of how to implement Joint Database Technology/Methodology. Inparticular the King James Bible Navigator software DEMO I posted which used FlatFile/SDBM for its database. I have made this a native Windows GUI application (TreeView/RichEdit COMBO interface) to demonstrate how to show your end-users a summary of the information of the data contained within a database, and allow them to drill down to a small amount of specific information (e.g. verses within a single book/chapter) for actual viewing (and retrieving from the database). The TreeView Double Click Event was originally written to random access the first verse within a chapter, then sequentially access the remaining verses within a chapter - performing a READ for each verse. I posted a separate modified TreeView Double Click Event for you to insert into the Application which reads an entire chapter in one (1) giant READ, breaking out the individual verses (into an array) using the UNPACK statement. -- Eric

    Joint Database Technology: http://www.perlmonks.org/?node_id=1121222

STFL Terminal UI - Concurrency Demonstrations
2 direct replies — Read more / Contribute
by marioroy
on Oct 07, 2017 at 20:16

    Hello brothers and sisters of the monastery,

    I came across a dated article by Philip Durbin (from 10/2011). I thought to give MCE::Hobo a try and see how it goes.

    The STFL library, a curses-based widget set for text terminals, compiles seamlessly on the Linux platform. Ncurses development libraries and swig are needed on CentOS 7.3. I've not tested on other Unix platforms.

    sudo yum install ncurses-devel swig tar xzf /path/to/stfl-0.24.tar.gz cd stfl-0.24 # Modify Makefile and comment out the SWIG lines #ifeq ($(FOUND_SWIG)$(FOUND_PERL5),11) #include perl5/Makefile.snippet #endif #ifeq ($(FOUND_SWIG)$(FOUND_PYTHON),11) #include python/Makefile.snippet #endif #ifeq ($(FOUND_SWIG)$(FOUND_RUBY),11) #include ruby/Makefile.snippet #endif sudo make install # Finally, build the Perl module cd perl5 swig -Wall -perl stfl.i perl Makefile.PL sudo make install

    example.stfl

    From the STFL documentation, a special language is used to describe the STFL GUI.

    ** * example.stfl: STFL layout for example1.pl and example2.pl. ** vbox hbox .expand:0 @style_normal:bg=yellow,fg=black label text:'Little STFL Program' label["label 1"] text["text 1"]:"10000" label["label 2"] text["text 2"]:"20000" label["label 3"] text["text 3"]:"30000" table .expand:0 @input#style_focus:bg=blue,fg=white,attr=bold @input#style_normal:bg=blue,fg=black @input#.border:rtb @L#style_normal:fg=red @L#.expand:0 @L#.border:ltb @L#.spacer:r label#L text:'Field A:' input .colspan:3 text[value_a]:'foo' tablebr label#L text:'Field B:' input text[value_b]:'bar' label#L text:'Field C:' input text[value_c]:'baz' label .expand:v .tie:bl text[helpmsg]:''

    example_p1.pl

    Each worker increments a shared counter. What is cool about STFL is being able to enter text while the counters increment simultaneously in the terminal. Pressing F2 signals the workers to exit. F1 spawns new Hobo workers. Pressing ESC or Ctrl-C (handled by MCE::Signal) exits the application.

    #!/usr/bin/env perl use strict; use warnings; use stfl; use MCE::Hobo 1.831; use MCE::Shared; use Time::HiRes qw/sleep/; my $count1 = MCE::Shared->scalar(10000); my $count2 = MCE::Shared->scalar(20000); my $count3 = MCE::Shared->scalar(30000); my $layout; { open my $fh, "<", "example.stfl" or die "open error 'example.stfl': $!"; local $/; $layout = <$fh>; } my $f = stfl::create($layout); my $s = 0; # MCE::Hobo 1.832 and later releases will set posix_exit # automatically when present, $INC{'stfl.pm'}. MCE::Hobo->init( posix_exit => 1 ); sub bg_start { unless ($s) { mce_async { sleep(0.9), $count1->incr() while 1 }; mce_async { sleep(0.6), $count2->incr() while 1 }; mce_async { sleep(0.3), $count3->incr() while 1 }; $s = 1; } } sub bg_stop { if ($s) { $_->exit()->join() for MCE::Hobo->list(); $s = 0; } } $f->set('helpmsg', '[ ESC = exit | F1 = start | F2 = stop ]'); bg_start(); while (1) { my $event = $f->run(50); if ($s) { # must stringify in case numeric value $f->set('text 1', ''.$count1->get()); $f->set('text 2', ''.$count2->get()); $f->set('text 3', ''.$count3->get()); } next unless (defined $event); bg_start() if $event eq 'F1'; bg_stop() if $event eq 'F2'; last if $event eq 'ESC'; } bg_stop();

    example_p2.pl

    Here, workers enqueue the form ID and value into a queue. The main process makes one trip to the shared-manager, maximum 3 replies.

    #!/usr/bin/env perl use strict; use warnings; use stfl; use MCE::Hobo 1.831; use MCE::Shared; use Time::HiRes qw/sleep/; my $q = MCE::Shared->queue(); my $layout; { open my $fh, "<", "example.stfl" or die "open error 'example.stfl': $!"; local $/; $layout = <$fh>; } my $f = stfl::create($layout); my $s = 0; # MCE::Hobo 1.832 and later releases will set posix_exit # automatically when present, $INC{'stfl.pm'}. MCE::Hobo->init( posix_exit => 1 ); mce_async { my $c = 10000; sleep(0.9), $q->enqueue([ 'text 1', ++$c ]) while 1; }; mce_async { my $c = 20000; sleep(0.6), $q->enqueue([ 'text 2', ++$c ]) while 1; }; mce_async { my $c = 30000; sleep(0.3), $q->enqueue([ 'text 3', ++$c ]) while 1; }; $f->set('helpmsg', '[ ESC = exit ]'); while (1) { my $event = $f->run(50); foreach my $ret ($q->dequeue_nb(3)) { # must stringify in case numeric value $f->set($ret->[0], ''.$ret->[1]); } next unless (defined $event); last if $event eq "ESC"; } $_->exit()->join() for MCE::Hobo->list();

    Entering text into an input box and have other areas of the form update automatically is quite nice. Furthermore, a worker may run an event loop and not impact the main process. There are a lot of possibilities.

    Regards, Mario

Meteoalarm - Weather warnings
1 direct reply — Read more / Contribute
by walto
on Sep 23, 2017 at 00:50
    Meteoalarm.eu (http://meteoalarm.eu) is the official website from European national weather services that gives out warnings in extreme weather situations. It has been a while ago that i wrote a perl module for processing this information. (Weather warnings from www.meteoalarm.eu). The website is still on but has changed since. That made some changes necessary. I wrote the module only for informational purposes and it is not meant to use it for anything critical. Here is the code:
    #!/usr/bin/perl # # package Meteoalarm; use strict; use warnings; use Carp; use LWP; use HTML::Entities; use HTML::TreeBuilder; use utf8; binmode STDOUT, ":encoding(UTF-8)"; our $VERSION = "0.06"; sub new { my $class = shift; my $self = {}; my %passed_params = @_; $self->{'user_agent'} = _make_user_agent( $passed_params{'user_agent'} ); bless( $self, $class ); return $self; } sub countries { my $self = shift; my %passed_params = @_; my %type = ( 'all' => 0, 'wind' => 1, 'snow' => 2, 'ice' => 2, 'snow/ice' => 2, 'thunderstorm' => 3, 'fog' => 4, 'extreme high temperature' => 5, 'extreme low temperature' => 6, 'coastal event' => 7, 'forestfire' => 8, 'avalanches' => 9, 'rain' => 10, 'unnamed' => 11, 'flood' => 12, 'rainflood' => 13 ); if ( !$passed_params{type} ) { $passed_params{type} = 0; } elsif ( !$type{ $passed_params{type} } ) { $passed_params{type} = 0; } else { $passed_params{type} = $type{ $passed_params{type} }; } my %day = ( 'today' => 0, 'tomorrow' => 1 ); if ( !$passed_params{day} ) { $passed_params{day} = 0; } elsif ( !$day{ $passed_params{day} } ) { $passed_params{day} = 0; } else { $passed_params{day} = $day{ $passed_params{day} }; } my $url = _make_country_url( $passed_params{day}, $passed_params{type} ); my $content = _fetch_content( $url, $self->{'user_agent'} ); my $country_warnings = _parse_country_warnings($content); return $country_warnings; } sub regions { my ($self) = shift; my %passed_params = @_; my %day = ( 'today' => 0, 'tomorrow' => 1 ); if ( !$passed_params{day} ) { $passed_params{day} = 0; } elsif ( !$day{ $passed_params{day} } ) { $passed_params{day} = 0; } else { $passed_params{day} = $day{ $passed_params{day} }; } my %type = ( 'all' => 0, 'wind' => 1, 'snow' => 2, 'ice' => 2, 'snow/ice' => 2, 'thunderstorm' => 3, 'fog' => 4, 'extreme high temperature' => 5, 'extreme low temperature' => 6, 'coastal event' => 7, 'forestfire' => 8, 'avalanches' => 9, 'rain' => 10, 'unnamed' => 11, 'flood' => 12, 'rainflood' => 13 ); my %country_codes = ( 'AT' => 'AT-Austria', 'BA' => 'BA_Bosnia-Herzegovina', 'BE' => 'BE-Belgium', 'BG' => 'BG-Bulgaria', 'CH' => 'CH-Switzerland', 'CY' => 'CY-Cyprus', 'CZ' => 'CZ-Czechia', 'DE' => 'DE-Germany', 'DK' => 'DK-Denmark', 'EE' => 'EE-Estonia', 'ES' => 'ES-Spain', 'FI' => 'FI-Finland', 'FR' => 'FR-France', 'GR' => 'GR-Greece', 'HR' => 'HR-Croatia', 'HU' => 'HU-Hungary', 'IE' => 'IE-Ireland', 'IL' => 'IL-Israel', 'IS' => 'IS-Iceland', 'IT' => 'IT-Italy', 'LT' => 'LT-Lithuania', 'LU' => 'LU-Luxemburg', 'LV' => 'LV-Latvia', 'MD' => 'MD-Moldova', 'ME' => 'ME-Montenegro', 'MK' => 'MK-Former Yugoslav Republic of Macedonia', 'MT' => 'MT-Malta', 'NL' => 'NL-Netherlands', 'NO' => 'NO-Norway', 'PL' => 'PL-Poland', 'PT' => 'PT-Portugal', 'RO' => 'RO-Romania', 'RS' => 'RS-Serbia', 'SE' => 'SE-Sweden', 'SI' => 'SI-Slovenia', 'SK' => 'SK-Slovakia', 'UK' => 'UK-United-Kingdom' ); if ( !$passed_params{type} ) { $passed_params{type} = 0; } elsif ( !$type{ $passed_params{type} } ) { $passed_params{type} = 0; } else { $passed_params{type} = $type{ $passed_params{type} }; } croak "Invalid country_code: $passed_params{country_code}" unless $passed_params{country_code}; my $url = 'http://meteoalarm.eu/en_UK/' . $passed_params{day} . '/' . $passed_params{type} . '/' . $country_codes{ $passed_params{country_code} } . '.html'; my $content = _fetch_content( $url, $self->{'user_agent'} ); my $region_warnings = _parse_region_warnings($content); return $region_warnings; } sub details { my $self = shift; my %passed_params = @_; my %country_codes = ( 'AT' => 10, 'BA' => 10, 'BE' => 801, 'BG' => 28, 'CH' => 319, 'CY' => 1, 'CZ' => 14, 'DE' => 808, 'DK' => 8, 'EE' => 805, 'ES' => 831, 'FI' => 813, 'FR' => 94, 'GR' => 16, 'HR' => 806, 'HU' => 7, 'IE' => 804, 'IL' => 803, 'IS' => 11, 'IT' => 20, 'LT' => 801, 'LU' => 2, 'LV' => 804, 'MD' => 37, 'ME' => 3, 'MK' => 6, 'MT' => 1, 'NL' => 807, 'NO' => 814, 'PL' => 802, 'PT' => 26, 'RO' => 42, 'RS' => 11, 'SE' => 813, 'SI' => 801, 'SK' => 16, 'UK' => 16 ); my ( $region, $code ) = $passed_params{region_code} =~ /^([ABCDEFGHILMNPRSU][A-Z])(\d\d\ +d)/; $code =~ s /^0//; croak "Invalid region_code: $passed_params{region_code}" unless ( $country_codes{$region} and ( $code <= $country_codes{$region} ) ); my $details; my %type = ( 'all' => 0, 'wind' => 1, 'snow' => 2, 'ice' => 2, 'snow/ice' => 2, 'thunderstorm' => 3, 'fog' => 4, 'extreme high temperature' => 5, 'extreme low temperature' => 6, 'coastal event' => 7, 'forestfire' => 8, 'avalanches' => 9, 'rain' => 10, 'unnamed' => 11, 'flood' => 12, 'rainflood' => 13 ); if ( !$passed_params{type} ) { $passed_params{type} = 0; } elsif ( !$type{ $passed_params{type} } ) { $passed_params{type} = 0; } else { $passed_params{type} = $type{ $passed_params{type} }; } my %day = ( 'today' => 0, 'tomorrow' => 1 ); if ( !$passed_params{day} ) { $passed_params{day} = 0; } elsif ( !$day{ $passed_params{day} } ) { $passed_params{day} = 0; } else { $passed_params{day} = $day{ $passed_params{day} }; } my $url = 'http://meteoalarm.eu/en_UK/' . $passed_params{day} . '/' . $passed_params{type} . '/' . $passed_params{region_code} . '.html'; my $content = _fetch_content( $url, $self->{'user_agent'} ); $details = _parse_details($content); return $details; } sub codes { my $self = shift; my @codes; my @countries_short; if (@_) { @countries_short = @_; } else { @countries_short = qw(AT BA BE BG CH CY CZ DE DK EE ES FI FR GR HR HU IE IL IS +IT LT LU LV MD ME MK MT NL NO PL PT RO RS SE SI SK UK); } my %country_codes = ( 'AT' => 'AT-Austria', 'BA' => 'BA_Bosnia-Herzegovina', 'BE' => 'BE-Belgium', 'BG' => 'BG-Bulgaria', 'CH' => 'CH-Switzerland', 'CY' => 'CY-Cyprus', 'CZ' => 'CZ-Czechia', 'DE' => 'DE-Germany', 'DK' => 'DK-Denmark', 'EE' => 'EE-Estonia', 'ES' => 'ES-Spain', 'FI' => 'FI-Finland', 'FR' => 'FR-France', 'GR' => 'GR-Greece', 'HR' => 'HR-Croatia', 'HU' => 'HU-Hungary', 'IE' => 'IE-Ireland', 'IL' => 'IL-Israel', 'IS' => 'IS-Iceland', 'IT' => 'IT-Italy', 'LT' => 'LT-Lithuania', 'LU' => 'LU-Luxemburg', 'LV' => 'LV-Latvia', 'MD' => 'MD-Moldova', 'ME' => 'ME-Montenegro', 'MK' => 'MK-Former Yugoslav Republic of Macedonia', 'MT' => 'MT-Malta', 'NL' => 'NL-Netherlands', 'NO' => 'NO-Norway', 'PL' => 'PL-Poland', 'PT' => 'PT-Portugal', 'RO' => 'RO-Romania', 'RS' => 'RS-Serbia', 'SE' => 'SE-Sweden', 'SI' => 'SI-Slovenia', 'SK' => 'SK-Slovakia', 'UK' => 'UK-United-Kingdom' ); foreach my $country_short (@countries_short) { my $url = 'http://meteoalarm.eu/en_UK/' . '0' . '/' . '0' . '/' . $country_codes{$country_short} . '.html'; my $content = _fetch_content( $url, $self->{'user_agent'} ); push @codes, _parse_codes($content); } return @codes; } sub _make_country_url { my ( $day, $type ) = @_; my $url = 'http://meteoalarm.eu/en_UK/' . $day . '/' . $type . '/EU-Europe +.html'; return $url; } sub _fetch_content { my ( $url, $user_agent ) = @_; my $ua = LWP::UserAgent->new; $ua->agent($user_agent); my $res = $ua->request( HTTP::Request->new( GET => $url ) ); croak " Can't fetch http://meteoalarm.eu: $res->status_line \n" unless ( $res->is_success ); return $res->decoded_content; } sub _parse_country_warnings { my $content = shift; my $p = HTML::TreeBuilder->new_from_content($content); my (%data); my @cells = $p->look_down( _tag => q{td}, class => qr/^col[12]$/ ) +; for my $cell (@cells) { my @src; my $div = $cell->look_down( _tag => q{div} ); my $id = $div->id; my $alt = $div->attr(q{alt}); $data{$id}{fullname} = $alt; my @weather_events = $div->look_down( _tag => 'span', class => qr{warn awt} ); $data{$id}{warnings} = _parse_weather_events( \@weather_events ); # # get tendency # my $tendency = $div->look_down( _tag => 'div', class => qr{tendenz awt nt l\d} ); if ( $tendency->{class} ) { $tendency->{class} =~ /tendenz awt nt l(\d)/; $data{$id}{tendency} = $1; } } return \%data; } sub _parse_region_warnings { my $content = shift; my $p = HTML::TreeBuilder->new_from_content($content); my (%data); my @cells = $p->look_down(_tag=>qr{div}, id=>qr{area}); for my $cell (@cells) { $cell->id =~ /area_([A-Z][A-Z]\d+)/; my $id = $1; my $fullname = $cell->look_down(_tag=>'span',id=>'cname')->as_text +; my $div = $cell->look_down( _tag => q{div} ); $data{$id}{fullname} = $fullname; my @weather_events = $div->look_down(_tag=> 'span', class=>qr{warnflag warn2}); $data{$id}{warnings} = _parse_weather_events( \@weather_events ); # # get tendency # my $tendency = $div->look_down( _tag => 'span', class => qr{tendenz awt\d l\d} ); if ( $tendency->{class} ) { $tendency->{class} =~ /tendenz awt\d l(\d)/; $data{$id}{tendency} = $1; } } return \%data; } sub _parse_weather_events { my $events = shift; my %weather_to_text = ( # lower case for consistency 1 => 'wind', 2 => 'snow/ice', 3 => 'thunderstorm', 4 => 'fog', 5 => 'extreme high temperature', 6 => 'extreme low temperature', 7 => 'coastal event', 8 => 'forestfire', 9 => 'avalanches', 10 => 'rain', 11 => 'unnamed', 12 => 'flood', 13 => 'rainflood' ); my %literal_warnings; for my $event (@$events) { #print $event->{class}, "\n"; $event->{class} =~ /warn\d* awt l(\d+) t(\d+)/; my $warn_level = $1; my $weather = $2; $literal_warnings{ $weather_to_text{$weather} } = $warn_level; } return \%literal_warnings; } sub _parse_details { my $content = shift; my (%data); my $p = HTML::TreeBuilder->new_from_content( decode_entities $cont +ent); $data{fullname} = $p->look_down( _tag => q{h1} )->as_text; if ( $p->look_down( _tag => q{div}, class => q{warnbox awt nt l l1} ) ) { $data{warnings} = 'no warnings'; } else { my @warnboxes = $p->look_down( _tag => q{div}, class => qr/warnbox awt/ ); for my $warnbox (@warnboxes) { my ($as_txt); my @info_divs = $warnbox->look_down( _tag => q{div}, class => q{info} ); $as_txt = $info_divs[0]->as_text; my ( $from, $until ) = $as_txt =~ /valid from (.*) Until ( +.*)$/; $as_txt = $info_divs[1]->as_text; my ( $warning, $level ) = $as_txt =~ /(.+?)\s+Awareness Level:\s+(.*)/; $warning =~ s/s$//; my $text = $warnbox->look_down( _tag => q{div}, class => q{text} )->as_text; $data{warnings}{ lc $warning } = { #lower case for constistency level => $level, from => $from, until => $until, text => $text, }; } } return \%data; } sub _parse_codes { my $content = shift; my $p = HTML::TreeBuilder->new_from_content($content); my (%data); #my @cells = $p->look_down( _tag => 'div', class => 'flags' ); my @cells = $p->look_down( _tag => qr{a} ); for my $cell (@cells) { if ( $cell->attr('xlink:href') ) { if ( $cell->attr('xlink:href') =~ /\/([A-Z][A-Z]\d+)-(.+?) +.html/ ) { my $code = $1; my $fullname = $2; $data{$fullname} = $code; } } } return \%data; } sub _make_user_agent { my $ua = shift; $ua = 'Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:55.0) Gecko/20100101 Fire +fox/55.0' unless ($ua); return $ua; } sub _extract_details_fullname { my $content = shift; my $region; if ( $content =~ /<h1>Weather warnings: (.+?)<\/h1>/ ) { $region = $1; decode_entities($region); if ( $region =~ /.??<.*<\/a>/ ) { $region =~ s/.??<.*<\/a>//; } } else { carp "Can't get region name\n"; } return $region; } 1; __END__ =head1 NAME B<Meteoalarm> - OO Interface for meteoalarm.eu =head1 SYNOPSIS This Module gets weather warnings from meteoalarm.eu. For further reading of terms and conditions see http://meteoalarm.eu/t +erms.php?lang=en_UK use Meteoalarm; my $meteo = Meteoalarm->new( 'user_agent' => 'Meteobot 0.001' ); my $countries = $meteo -> countries ('type' => 'all', 'day' => 'today' +); foreach my $country_code (sort keys %{$countries}){ print "Country: $countries->{$country_code}->{'fullname'}\n"; print "Tendency = $countries->{$country_code}->{tendency}\n" if ( +$countries->{$country_code}->{'tendency'}); if (keys %{$countries->{$country_code}->{'warnings'}}){ foreach my $warning (keys %{$countries->{$country_code}->{'warning +s'}}){ print "Event: $warning, severity: $countries->{$country_co +de}->{'warnings'}->{$warning}\n"; } } else {print "No Warnings\n";} } my $regions = $meteo->regions( 'country_code' => 'PT', 'day' => 'today +', 'type' => 'all' ); foreach my $code ( sort keys %{$regions} ) { print "Region : $regions->{$code}->{'fullname'}: region_code = $co +de\n" if ( keys %{ $regions->{$code}->{'warnings'} } ); print "Tendency = $regions->{$code}->{tendency}\n" if ( $regions-> +{$code}->{'tendency'}); foreach my $type ( keys %{ $regions->{$code}->{'warnings'} } ) { print "$type Severity: $regions->{$code}->{'warnings'}->{$type}\n"; } } my $details = $meteo->details( 'region_code' => 'UK010', 'day' => 'tod +ay'); my $name = $details->{'fullname'}; print "$name\n"; if ( $details->{warnings} eq 'no warnings' ) { print $details->{warnings}, "\n"; } else { foreach my $warning ( keys %{ $details->{'warnings'} } ) { print "$warning\n"; foreach my $detail ( keys %{ $details->{'warnings'}->{$warning +} } ) { print "$detail: $details->{'warnings'}->{$warning}->{$deta +il}\n"; } } } my $codes = $meteo->codes('FR'); my @codes = $meteo->codes(); foreach my $code (@codes) { foreach my $region ( sort keys %{$code} ) { print "Region name: $region, region code: $code->{$region}\n"; } } =head1 DESCRIPTION $meteo -> countries returns hashref of warnings for all countries. $meteo -> regions returns hashref of warnings for all regions in a spe +cified country $meteo -> details returns hashref of detailled warnings for a specifie +d region $meteo -> codes returns arrayref of hash of name and region code of a +country =head1 METHODS =head1 new( ) creates a new meteoalarm object =head2 Optional Arguments: new( 'user_agent' => 'Meteobot 0.001'); changes the user agent string =head1 my $country = $meteo -> countries (); =head2 Optional Arguments: 'day' => 'today' || 'tomorrow' if day is not defined, default value is today 'type' => 'all' || 'wind' || 'snow' || 'ice' || 'snow/ice' || +'snow' || 'ice' || 'thunderstorm' || 'fog' || 'extreme high temperature' +|| 'extreme low temperature' || 'coastal event' || 'fores +tfire' || 'avalanches' || 'rain' if type is not defined, default type is all =head1 $regions = $meteo -> regions ('country_code' => 'DE'); country_code is a 2 letter abbreviation =head2 Optional arguments: day=> 'today' || 'tomorrow' if day is not defined, default value is today =head1 $details = $meteo->details ('region_code' => 'ES005'); region_code consits of 2 letters for the country and 3 digits =head2 Optional arguments: day=> 'today' || 'tomorrow' if day is not defined, default value is today =head1 $code = $meteo -> codes (); Returns arrayref of hash for region names and codes for all countries =head2 Optional Arguments $code = $meteo -> codes ('PL'); Countrycode for a specific country =cut
Script to determine whether the cables are plugged into the correct ports in a EX2200
1 direct reply — Read more / Contribute
by Anonymous Monk
on Sep 13, 2017 at 11:10
    #!/usr/bin/perl -w use strict; use Net::Ping; use threads; ###################################################################### +#################################################### # # PURPOSE: This script tries to determine if the cables are plugged in +to the correct ports in the EX2200 switch in a store # # LOGIC: 1) get store number from command line argument # 2) lookup store IP address using store number # 3) Ping devices in store to populate ARP table in SRX # 4) Collect ARP table from SRX and ethernet-switching table f +rom EX2200 with an expect script # 5) Parse the outputs and merge based on MAC address. Ignore + all devices in VLAN.16 as they are wireless devices # 6) Special handling for WLA plugged into port 47. This is O +K only if there is not another WLA in port 46 # 7) Create report or pass info to next program # # USER INPUT: The store number for the store to be tested # # HARDCODED INPUT: $storeFile - this is a file created from allstores +.xlsx that maps store number to IP address and the # other data in allstores. this script + only needs the store IP address # $portFile - this file contains a mapping between +the last octet of the IP address of a store device, # the port number that it should be plu +gged into, and the description of the device. # $user - userid to access SRX and EX2200 # $pwd - password to access SRX and EX2200 # # USAGE: perl chackwiring.pl <store number> # # RETURN CODES: 0 - success # 101 - store IP address not in $storeFile # 102 - cannot reach store # 103 - could not open file created by expect script # 104 - could not open $portFile # 105 - could not open $storeFile # 106 - could not clear the old data in $filename prior + to running expect script # The following return codes are bit flags and can be combined by +adding: # 1 - could not connect to SRX # 2 - could not connect to EX2200 # 4 - did not parse any show arp records # 8 - did not parse any show ethernet-switching table + records # ###################################################################### +#################################################### # ============================ # user changeable variables # ============================ my $user = "root"; my $pwd = "Pa55word"; my $portFile = "porttable"; # table with port to IP association my $storeFile = "store_data_2.txt"; # data about stores extracted from + allstores.xlsx my $debugLevel = 10; my $icmpTimeout = 1; # timeout for ping, default of 1 is probab +ly ok. my @pingList = (); # ============================ # hashes used for data storage # ============================ my %cable_hash = (); my %port_hash = (); my %device_info_hash = (); my %store_info_hash = (); my %device_ip_hash = (); my %port_to_mac_hash = (); # ========================================= # debug info to calculate run time # ========================================= if ($debugLevel) { my $t1 = getTimestamp(); print "starting time is $t1\n"; } # ========================================= # get requested store from command line # ========================================= my $storeNum = 0; if ( $#ARGV > -1) { $storeNum = $ARGV[0]; print "asking for store $storeNum\n" if ($debugLevel > 5 ); } # ========================================= # get store info so we can get store's IP address # ========================================= getStoreInfo(); unless (defined ( $store_info_hash{$storeNum}{ip})) { print "store $storeNum not found\n"; exit 101; } # ========================================= # variables filled in based on store number # ========================================= my $storeIp = $store_info_hash{$storeNum}{ip}; print "StoreIP is $storeIp\n" if ($debugLevel > 0 ); my $base_ip = $store_info_hash{$storeNum}{ip}; my $srx_ip = $base_ip . ".193"; my $ex_ip = $base_ip . ".2"; my $filename = "report_" . $storeNum . ".txt"; my $fatalError = 0; # ========================================= # count number of reachable devices in store # ========================================= my $upCount = 0; # ========================================= # ping store devices to populate ARP table # need to ping any address that might be # assigned to a device plugged into the EX # ========================================= addRangeToPingList( 1, 15); # ISP, safes, RILO ,ATG, ATMs addRangeToPingList( 20, 24); # POS addRangeToPingList( 30, 34); # POS pinpad addRangeToPingList( 43, 44); # scanner and GOT docking stations addRangeToPingList( 50, 51); # printer addRangeToPingList( 60, 68 ); # HVAC, training, DVR addRangeToPingList( 154, 158 ); # WLA $upCount = pingArrayThreaded ($base_ip); # ========================================= # debug info to calculate run time # ========================================= if ($debugLevel) { my $t2 = getTimestamp(); print "ping complete at time is $t2\n"; } # ========================================= # if we can't reach anything, store is down # ========================================= unless ($upCount ) { print "cannot reach store\n"; exit 102; } # ========================================= # clear the data file for the expect script output # ========================================= open( OUTFILE, ">", $filename ) or do { $fatalError = 106; print "FATAL_ERROR: could not clear $filename to avoid stale data +\n"; exit $fatalError; }; print OUTFILE "Cleared to avoid stale data\nIf this message is here af +ter running the script, the expect script did not run\n"; close OUTFILE; # ========================================= # debug info to calculate run time # ========================================= if ($debugLevel) { my $t4 = getTimestamp(); print "calling expect script at time is $t4\n"; } # ========================================= # get show arp and show ethernet-switching table # ========================================= my $datestamp = getTimestamp(); my $expectCommand = "/home/jstank01/test/showarp.exp " . $srx_ip . " " + . $ex_ip . " " . $user . " " . $pwd . " " . $filename; system ( $expectCommand ); # ========================================= # debug info to calculate run time # ========================================= if ($debugLevel) { my $t5 = getTimestamp(); print "completed expect script at time is $t5\n"; } # ========================================= # get association between port number and # IP address # ========================================= getPortData(); # ========================================= # parse show arp and show ethernet-switching table # ========================================= parseData(); # ========================================= # print the report # ========================================= printData($storeNum, $datestamp ); # ========================================= # debug info to calculate run time # ========================================= if ($debugLevel) { my $t3 = getTimestamp(); print "script complete at time is $t3\n"; } # normal termination exit 0; ##################################################################### # This subroutine pings a single IP address # it is executed in a thread ##################################################################### sub threadedPing { my ($ipaddr) = @_; my $p=Net::Ping->new("icmp", $icmpTimeout ); unless($p->ping($ipaddr)){ return 0; } else { return 1} } ##################################################################### # This subroutine parses the data file created by # the expect script. The file contains the output # of "show arp" from the SRE and the output of # "show ethernet-switching table" from the EX # Once it determines which device is in each port, # it adds the expected port for the device to the # record. Additionally, it handles the special case # of 2 WLAs in the store. ##################################################################### sub parseData { open( INFILE, $filename ) or do { $fatalError = 103; print "FATAL_ERROR: could not open $filename (expect output) for +reading\n"; exit $fatalError; }; my $ap_in_46 = 0; my $arpRecordCount = 0; my $switchRecordCount = 0; while ( <INFILE>) { chomp; my $line = $_; # match ARP entry from SRX if ($line =~ /([0-9A-Fa-f\:]+)[ \t]+([0-9]+\.[0-9]+\.[0-9]+\.([0-9]+)) +[ \t]+([^ \t]+)[ \t]+(vlan\.([0-9]+))/) { my $mac = $1; my $ip = $2; my $lastOctet = $3; my $vlan = $5; my $vlanNum = $6; # ignore vlan 16 which is wireless devices if (16 != $vlanNum) { $arpRecordCount++; $cable_hash{$mac}{ip} = $ip; $cable_hash{$mac}{vlan} = $vlan; $cable_hash{$mac}{last_octet} = $lastOctet; if (exists ($port_hash{$lastOctet}{port})) { $cable_hash{$mac}{correct_port} = $port_hash{$lastOctet}{port}; $cable_hash{$mac}{description} = $port_hash{$lastOctet}{descr +iption}; } else { # octet not found in port table, put in 999 because unknown $cable_hash{$mac}{correct_port} = 999; } } # endif (16 != $vlanNum) } # endif match ARP entry # match ethernet switching table entry if ($line =~ /([^ ]+)[ \t]+([0-9A-Fa-f\:]+)[ \t]+([^ \t]+)[ \t]+[0-9]+ +[ \t]+(ge-0\/0\/([0-9]+))/) { $switchRecordCount ++; my $mac = $2; my $fullPort = $4; my $shortPort = $5; $cable_hash{$mac}{full_port} = $fullPort; $cable_hash{$mac}{short_port} = $shortPort; } # endif ethernet-switching table entry if ($line =~ /EXPECT_ERROR.*SRX/) { $fatalError = 1; print "FATAL ERROR: Could not connect to SRX\n"; } if ($line =~ /EXPECT_ERROR.*EX/) { $fatalError += 2; print "FATAL ERROR: Could not connect to EX2200\n"; } } # end while ( <INFILE>) close INFILE; # ============================================ # create hash which associates port numbers to # mac addresses. We only care about ports that # have an IP address. Also check if there is about # valid WLA plugged into port 46. This is used # to see if it is ok to have a WLA in port 47 # ============================================ foreach my $mac (keys %cable_hash) { if ((defined $cable_hash{$mac}{ip}) && (defined $cable_hash{$mac}{ful +l_port}) ){ $port_to_mac_hash{$cable_hash{$mac}{short_port}} = $mac; if ((46 == $cable_hash{$mac}{short_port}) && (46 == $cable_hash{$ma +c}{correct_port})) { $ap_in_46 = 1; } } } # ============================================ # handle stores that have 2 WLAs. Update correct # port for port 47 if there is a valid WLA in # port 46 # ============================================ if ($ap_in_46 && ( defined $port_to_mac_hash{47}) ){ if (46 == $cable_hash{$port_to_mac_hash{47}}{correct_port}) { $cable_hash{$port_to_mac_hash{47}}{correct_port} =47; } } # ============================================ # make sure we have ARP info and ethernet-switching # table info # # ============================================ unless ($arpRecordCount) { print "FATAL ERROR: Did not get ARP records from SRX\n"; $fatalError += 4; } unless ($switchRecordCount) { print "FATAL ERROR: Did not get ethernet-switching table records fr +om EX2200\n"; $fatalError += 8; } exit $fatalError if ($fatalError); } # end sub parseData ##################################################################### # This is a dummy routine to print the results # of looking a the cabling in the store. This # should be replaced with a subroutine that puts # the data where it can be sent to the end user # MAC and IP address not printed unless debugging is on ##################################################################### sub printData { my ($storeNum, $datestamp ) = @_; print "Cabling report for store $storeNum generated at $datestamp\n\n" +; foreach my $key (sort { $a <=> $b } keys %port_to_mac_hash) { my $mac = $port_to_mac_hash{$key}; if ($debugLevel >10 ) { print $mac; print "\t"; print $cable_hash{$mac}{ip}; print "\t"; print $cable_hash{$mac}{last_octet}; print "\t"; } printf '%-18s' , $cable_hash{$mac}{description}; print "\t"; print $cable_hash{$mac}{full_port}; print "\t"; if ($debugLevel >10 ) { print $cable_hash{$mac}{short_port}; print "\t"; print $cable_hash{$mac}{correct_port}; print "\t"; } if ( $cable_hash{$mac}{correct_port} != $cable_hash{$mac}{short_port +}) { print "Move cable in port " . $cable_hash{$mac}{short_port} . " to + port " . $cable_hash{$mac}{correct_port}; } else { print "OK"; } print "\n"; } } # end sub printData ##################################################################### # This subroutine reads the file that has the # expected last octet of the IP address that belongs # in each port. ##################################################################### sub getPortData { open( INFILE, $portFile ) or do { $fatalError = 104; print "FATAL_ERROR: could not open $filename (port to address ass +ociations) for reading\n"; exit $fatalError; }; while ( <INFILE>) { chomp; my $line = $_; if ($line =~ /([0-9]+)[ \t]+([0-9]+)[\t]+(.*)/) { my $octet = $1; my $port = $2; my $description = $3; $port_hash{$octet}{port} = $port; $port_hash{$octet}{description} = $description; }elsif ($line =~ /([0-9]+)[ \t]+([0-9]+)/) { my $octet = $1; my $port = $2; $port_hash{$octet}{port} = $port; $port_hash{$octet}{description} = ""; } } close INFILE; } # end sub getPortData #################################################################### # # read the store info file # This file contains the info from allstores.xlsx in a # script friendly format # ##################################################################### + sub getStoreInfo { my $COL_hostname = 0; my $COL_ip = 8; my $COL_t1_addr = 15; my $COL_t1_peer_addr = 14; #my $COL_avn_nbr = my $COL_local_as = 16; my $COL_st0_unit0_addr = 12; my $COL_st0_unit0_peer = 11; my $COL_st0_unit1_addr = 10; my $COL_st0_unit1_peer = 9; my $COL_state = 3; my $COL_city =2; # ===================================================== # device variables for all stores # ===================================================== open( STOREFILE, $storeFile ) or do { $fatalError = 105; print "FATAL_ERROR: could not open $storeFile (store information) + for reading\n"; exit $fatalError; }; # ===================================================== # go through all devices and build hash based on ip # # ===================================================== while (<STOREFILE>) { chomp; my $line = $_; if ($line =~ /<STORENUM>/){ my @input_tags = split("\t", $line); for my $i (0 .. $#input_tags) { if ($input_tags[$i] =~ /<STORENUM>/ ) { $COL_hostname = $i; } if ($input_tags[$i] =~ /<LEGACY-OCTET>/ ) { $COL_ip = $i; } if ($input_tags[$i] =~ /<T1-WAN-ADDRESS>/ ) { $COL_t1_addr = $i; +} if ($input_tags[$i] =~ /<ATT-BGP-PEER-ADDR>/ ) { $COL_t1_peer_add +r = $i; } if ($input_tags[$i] =~ /<STORE-AS>/ ) { $COL_local_as = $i; } if ($input_tags[$i] =~ /<VPN-TUNNEL-1-ADDR>/ ) { $COL_st0_unit0_a +ddr = $i; } if ($input_tags[$i] =~ /<VPN-1-TUNNEL-PEER-ADDR>/ ) { $COL_st0_un +it0_peer = $i; } if ($input_tags[$i] =~ /<VPN-TUNNEL-2-ADDR>/ ) { $COL_st0_unit1_a +ddr = $i; } if ($input_tags[$i] =~ /<VPN-2-TUNNEL-PEER-ADDR>/ ) { $COL_st0_un +it1_peer = $i; } if ($input_tags[$i] =~ /<State>/ ) { $COL_state = $i; } if ($input_tags[$i] =~ /<City>/ ) { $COL_city = $i; } # if ($input_tags[$i] =~ /<SNMP-LOCATION>/ ) { $COL_city = $i; # $COL_state = -1; + } } next; } if ($line =~ /hostname[ \t]+ip/) {next;} # ===================================================== # read variables for a store # ===================================================== my @input_vars = split("\t", $line); my $store_number = $input_vars[$COL_hostname]; my $ip = $input_vars[$COL_ip]; if ($ip =~ /([0-9]*\.[0-9]*\.[0-9]*)/) { $ip = $1; } my $t1_addr = $input_vars[$COL_t1_addr]; my $t1_peer_addr = $input_vars[$COL_t1_peer_addr]; my $avn_nbr = '13979'; my $local_as = $input_vars[$COL_local_as]; #$input_vars[16]; my $st0_unit0_addr = $input_vars[$COL_st0_unit0_addr]; my $st0_unit0_peer = $input_vars[$COL_st0_unit0_peer]; my $st0_unit1_addr = $input_vars[$COL_st0_unit1_addr]; my $st0_unit1_peer = $input_vars[$COL_st0_unit1_peer]; my $state = $input_vars[$COL_state]; my $city = $input_vars[$COL_city]; my $bb_static_ip = '1.1.1.2/30'; #$input_vars[2]; my $bb_static_nh = '1.1.1.1'; #$input_vars[2]; # print "adding store <$store_number> ip <$ip>\n"; $device_ip_hash{$ip} = $store_number; $store_info_hash{$store_number}{ip} =$ip; $store_info_hash{$store_number}{state} =$state; } } # end getStoreInfo #################################################################### # # This subroutine creates a timestamp # # ##################################################################### + sub getTimestamp { my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) + = localtime(time); if ( $year > 99 ) { $year = $year + 1900; } $mon = $mon + 1; $mon = sprintf("%02d", $mon); $sec = sprintf("%02d", $sec); $min = sprintf("%02d", $min); $hour = sprintf("%02d", $hour); $mday = sprintf("%02d", $mday); $year = sprintf("%02d", $year); $wday = sprintf("%02d", $wday); $yday = sprintf("%02d", $yday); $isdst = sprintf("%02d", $isdst); my $datestamp = $mon . '-' . $mday . '-' .$year . ' ' . $hour . ':' . $min . ' +:' . $sec; return($datestamp); } # end sub getTimestamp #################################################################### # # This subroutine adds a range of octets to the list of devices to # be pinged. This list only contains the 4th octet of the addess # The first 3 octets are specified in $base_ip ##################################################################### + sub addRangeToPingList { my ( $start , $end) = @_; my $octet = $start; while ($octet <= $end) { push (@pingList, $octet); $octet++; } } # end sub addRangeToPingList ##################################################################### # This subroutine pings a list of IP addresses where # the first 3 octets are specified in $base_ip and the # 4th octet of each device to be pinged is in the array called pingLi +st ##################################################################### sub pingArrayThreaded { my ($base_ip) = @_; my $upCount = 0; my $octet; foreach my $octet (@pingList) { my $ipaddr = $base_ip . '.' . $octet; my $thr = threads->new(\&threadedPing , $ipaddr); $octet++; } # end while my @running = threads->list(threads::running); while ($#running > 0) { print "running " . $#running . " threads\n" if ($debugLevel >5); my @joinable = threads->list(threads::joinable); foreach my $joinableThr (@joinable) { $upCount += $joinableThr->join(); } sleep(1); @running = threads->list(threads::running); } my @joinable = threads->list(threads::joinable); foreach my $joinableThr (@joinable) { $upCount += $joinableThr->join(); } return ($upCount); } # end sub pingRange
New Tutorial: Embedded Perl, Installing Perl and Mojolicious on Arduino Yśn / OpenWRT ChaosCalmer
No replies — Read more | Post response
by ait
on Sep 11, 2017 at 22:58
decimal to fraction
2 direct replies — Read more / Contribute
by no_slogan
on Sep 11, 2017 at 02:16

    This is an update to an old node by esteemed monk tilly.

    Say you have a decimal number like 0.421875 and you want to print it as a fraction. Now, "obviously", that's equal to 27/64, but how do you write a program to find that out? The best way is with the method of continued fractions, and the surprise is that it's dead simple. This program produces a sequence of fractions that are increasingly good approximations of the input number.

    use Math::BigInt; use Math::BigRat; die 'number required' unless @ARGV == 1; my $x = my $y = Math::BigRat->new($ARGV[0])->babs(); my $h = my $k1 = Math::BigInt->new(1); my $k = my $h1 = Math::BigInt->new(0); while (1) { my $t = $y->as_int(); ($h, $h1) = ($t * $h + $h1, $h); ($k, $k1) = ($t * $k + $k1, $k); my $val = Math::BigRat->new($h, $k); my $err = $val - $x; printf "%s: %s / %s = %.16g (%.1g)\n", $t, $h, $k, $val, $err; $y -= $t or last; $y = 1 / $y; } __END__ 0: 0 / 1 = 0 (-0.4) 2: 1 / 2 = 0.5 (0.08) 2: 2 / 5 = 0.4 (-0.02) 1: 3 / 7 = 0.4285714285714285 (0.007) 2: 8 / 19 = 0.4210526315789473 (-0.0008) 3: 27 / 64 = 0.421875 (0)

    Clearly, this code is much simpler than before. What's not obvious is that it always terminates with $h/$k exactly equal to $x. In practice, you probably want to stop the loop early, perhaps when $err is small enough or $k gets too big.

    This algorithm can even tackle really obnoxious inputs like 0.49420098210293 (463051/936969).

    You can do away with BigInt and BigRat and use ordinary numbers, but then the loop is no longer guaranteed to terminate. To be safe, maybe put in a limit on the maximum number of iterations.

    The first number on each line, $t, is a term in the continued fraction representation. You can mostly ignore it, but it has some interesting mathematical properties. For example, if you set $x to sqrt(2), all terms after the first should be 2, but only the first 18 are correct because of round-off.

Safe string handling
2 direct replies — Read more / Contribute
by tdlewis77
on Aug 25, 2017 at 13:07
    Dealing with data that comes from webpages can be really complicated. There is likely to be a combination of ASCII, UTF-8, and wide characters in the data returned and you cannot depend on the website to tell you what type of content is being returned. The routines safeString, safeSubstr, testString, and trueLength can be used to easily manipulate these strings. Pass any string to safeString and you will never get a wide character warning from print. Use safeSubstr to extract complete UTF-8 characters sequences from a string. Use testString to tell you what's really in the string. Use trueLength to find out how many characters wide the output will be.
    # This string has a mixture of ASCII, UTF-8, 2 byte wide, and 4 byte # wide characters my $crazy = "Hello\x{26c4}".encode("utf-8","\x{26f0}"). "\x{10102}\x{2fa1b}"; # Now the string only has ASCII and UTF-8 characters my $sane = safeString($crazy); # testString($crazy) returns 7 # testString($sane) returns 3 # length($sane) returns 19 # trueLength($sane) returns 9 my $snowman = safeSubstr($crazy,5,1); ######################################## # safeString($string) # return a safe version of the string sub safeString { my ($string) = @_; return "" unless defined($string); my $t = testString($string); return $string if $t <= 3; return encode("utf-8",$string) if $t <= 5; # The string has both UTF-8 and wide characters so it needs # tender-loving care my @s = unpack('C*',$string); my @r; for (my $i = 0; $i < scalar(@s);) { if ($s[$i] < 128) { push @r, $s[$i]; $i++; } elsif ($s[$i] > 255) { # encode a wide character push @r,unpack("C*",encode("utf-8",chr($s[$i]))); $i++; } else { # copy all the utf-8 bytes $n = _charBytes($i,@s) - 1; map { push @r, $s[$i+$_] } 0..$n; $i += $n + 1; } } return pack("C*",@r); } ######################################## # safeSubstr($string,$pos,$n) # return a safe substring (treats utf-8 sequences as a single # character) sub safeSubstr { my ($string,$pos,$n) = @_; $s = safeString($string); my $p = 0; my $rPos = 0; my $rEnd = -1; my @s = unpack('C*',$s); for (my $i = 0; $i < scalar(@s);) { if ($s[$i] < 128) { $i++; } elsif ($s[$i] > 255) { $i++; } else { $i += _charBytes($i,@s); } $p++; $rPos = $i if $p == $pos; $rEnd = $i-1 if $p == $pos + $n; } $rEnd = scalar(@s) - 1 if $rEnd < 0; return "" if $rPos > $rEnd; my @r; map { push @r, $s[$_] } $rPos..$rEnd; return pack("C*",@r); } ######################################## # testString($string) # returns information about the characters in the string # # The 1, 2, and 4 bits of the result are for ASCII, UTF-8, and # wide characters respectively. If multiple bits are set, # characters of each type appear in the string. If the result is: # <= 1 simple ASCII string # <= 3 simple UTF-8 string # >3 && <= 5 mixed ASCII & wide characters # >= 6 mixed UTF-8 & wide characters sub testString { my ($s) = @_; return undef unless defined($s); my $r = 0; my @s = unpack('C*',$s); for (my $i = 0; $i < scalar(@s);) { if ($s[$i] < 128) { $r |= 1; $i++; } elsif ($s[$i] > 255) { $r |= 4; $i++; } else { $r |= 2; $i += _charBytes($i,@s); } } return $r; } ######################################## # trueLength($string) # returns the number of UTF-8 characters in a string sub trueLength { my ($s) = @_; return unless defined($s); my $len = 0; my @s = unpack('C*',$s); for (my $i = 0; $i < scalar(@s);) { if ($s[$i] < 128) { $i++; } elsif ($s[$i] > 255) { $i++; } else { $i += _charBytes($i,@s); } $len++; } return $len; } ######################################## # String support routines sub _charBytes { my $n = shift(@_); my $len = scalar(@_); if ($_[$n] < 128) { return 1; } elsif ($_[$n] > 65535) { return 4; } elsif ($_[$n] > 255) { return 2; } elsif (($_[$n] & 0xFC) == 0xFC) { return min(6,$len); } elsif (($_[$n] & 0xF8) == 0xF8) { return min(5,$len); } elsif (($_[$n] & 0xF0) == 0xF0) { return min(4,$len); } elsif (($_[$n] & 0xE0) == 0xE0) { return min(3,$len); } elsif (($_[$n] & 0xC0) == 0xC0) { return min(2,$len); } else { return 1; } }
Searching for exoplanets
No replies — Read more | Post response
by GrandFather
on Aug 24, 2017 at 02:53

    Wearing a different hat I do the odd spot of astronomy observation. One of the observation areas I'm interested in is recording data for microlensing events which can be used for discovering exoplanets. Detected candidate events are published in various places around the internet, but a chunk of digging and analysis is required to find events that are interesting to observe "tonight". The following code scrapes one of the sites and uses heuristics involving the brightness of the event and various other parameters to choose and prioritize interesting current events from the thousand or so listed.

    use strict; use warnings; use File::Copy; use HTML::Tree; use Astro::Time qw(); my $nowJD = Astro::Time::mjd2jd(Astro::Time::now2mjd()); my $root = HTML::TreeBuilder->new_from_url( 'http://ogle.astrouw.edu.pl/ogle4/ews/ews.html'); my @elements = $root->guts(); my @tables = $root->find('table'); my @rows = $tables[-1]->find('tr'); my @events; for my $row (@rows) { my @cells = $row->find('td'); my $flag = shift @cells; my ( $event, $field, $starNo, $ra, $dec, $tmaxHJD, $tmaxUT, $tau, $Umin, $Amax, $Dmag, $fbl, $ibl, $i0 ) = map {$_->as_text()} @cells; next if !$event || !$flag->find('img') || $Amax < 20; my $delta = abs($nowJD - $tmaxHJD); my $minMag = $i0 - $Dmag; next if $tau > 300 || $delta > $tau || $minMag > 16; $delta ||= 0.0001; $Umin ||= 0.0001; my $tRoot = $delta / $tau; my $uNow = sqrt($Umin * $Umin + $tRoot * $tRoot); my $aNow = ($uNow * $uNow + 2) / ($uNow * sqrt($uNow * $uNow + 4)) +; my $magNow = $i0 - 5 * log($aNow) / log(100); next if $magNow > 17; $magNow = sprintf "%.4f", $magNow; push @events, [$event, $tmaxUT, $tRoot, $tau, $ra, $dec, $Dmag, $m +agNow, $i0]; } for my $eventData (sort {$a->[2] <=> $b->[2]} @events) { my ($event, $tmaxUT, $tRoot, $tau, $ra, $dec, $Dmag, $magNow, $i0) + = map {s/^\s+|\s+$//g; $_} @$eventData; my $minMag = sprintf "%.3f", $i0 - $Dmag; print <<EVENT; $event: peak at $tmaxUT (tau $tau) RA $ra Dec $dec Mag $i0 - $minMag ( +now $magNow) EVENT }

    Run at 6:29 UT 2017/08/24 printed:

    2017-BLG-1600: peak at 2017-08-25.34 (tau 9.350) RA 17:43:38.19 Dec -2 +6:54:38.8 Mag 16.982 - 6.688 (now 14.6269) 2017-BLG-0019: peak at 2017-06-22.58 (tau 134.989) RA 17:52:18.74 Dec +-33:00:04.0 Mag 14.798 - 11.277 (now 13.8859)
    Premature optimization is the root of all job security
Command Shell
2 direct replies — Read more / Contribute
by tdlewis77
on Aug 23, 2017 at 01:08

    In 2002 I wanted to collect a bunch of code together to administer a gaming system. The main loop of the program accepted user input and invoked a routine to process the request. Eventually I decided that the idea of having a generic shell to which user-defined commands could be added would be useful and a crude version of a command shell was introduced in 2004. Over the intervening years the script and support routines have grown to over 8000 lines of code. Today I released version 3.0.

    Even if you don't find the concept of a command shell useful, there is a large collection of helpful functions in cs_fn.pl. For example, you will never get a "Wide character in print" error if you pass your strings to safeString.

    print safeString("\x{263A}\n");

    Home Page: http://www.exelana.com/techie/perl/cs.html

    Documentation: http://www.exelana.com/techie/perl/CommandShell.pdf

    Download: http://www.exelana.com/techie/perl/cs.tgz

    Let me know what you think!

Math::Base - arithmetics with baseX integers (updated)
2 direct replies — Read more / Contribute
by shmem
on Aug 22, 2017 at 08:19

    Another "Silly use for Perl" entry.

    Anonymous Monk asked for a method for incrementing mixed letters and numbers recently, which particular need is satisfied with Math::Base36. Can we do better? I guess, yes.

    use 5.10.0; use Math::Base; my $begin = Math::Base->new(36, 1009, 1); # base, number, is_encoded my $end = Math::Base->new(36, 1020, 1); my $c = Math::Base->new(36, 42); say $c->encode($_) for $begin .. $end; # 1009 # 100A # 100B # 100C # ... # 101X # 101Y # 101Z # 1020 # also (with updated code below) # my $x = Math::Base->new(36, 46664); # 1008 in base36 # say ++$x for 0..63; # output same as above # Arithmetics with different encodings: $p = Math::Base->new(8,777,1); # decimal 511 $z = Math::Base->new(36, 35); # 'Z' as base36 say $z * $p; # 42735 (octal) say $p * $z; # 'DST' (base36) # Changing the string representation: $s = Math::Base->new(16,18); say $s; # 12 $s->rebase(18); say $s; # 10 $s += 3; # 13 $s->rebase(2); say $s; # 10101 # Get decimal value: $xyz = Math::Base->new(64, 'XYZabc', 1); say $xyz->num; # 36013230438

    Far from complete, but fun enough yet. For me, that is... ;-)

    Update: Below is an updated version which handles negative numbers, implements missing operators and lets you define your own charset for baseX conversion, e.g. to calculate base3 with qw(a b c). Also, a method integer() is added which emulates use integer globally for all calculations, and some utility methods/functions.

    Update: fixed some bugs

    I'll eventually make it into a CPAN package proper.

    perl -le'print map{pack c,($-++?1:13)+ord}split//,ESEL'

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, 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, 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.