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

CUFP's
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
decimal to fraction
1 direct reply — 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'
moon illumination and eclipses
2 direct replies — Read more / Contribute
by no_slogan
on Aug 20, 2017 at 16:00
    Here's a relatively short program that calculates the fraction of illumination of the moon at a given time. This is relevant right now because it's a function of the angle between the sun and the moon. When the angle is small enough, there's a solar eclipse, as we will get a chance to see tomorrow. Unfortunately, the moon wobbles around in the sky too much for a simple program like this to cope with, so it can't produce high-accuracy eclipse predictions, but it might be interesting to some people. Visit JPL for more information.
Colour/color sampler
2 direct replies — Read more / Contribute
by Nige
on Aug 20, 2017 at 06:38

    So, an XML file or web post lists a bunch of colour specs like; 0x1e93c6, 0xf2b827, 0xd6563c, 0x6a5c9e, 0x31a35f; and you want to see what they look like.

    You could paste each one into a colour viewer, but I couldn't find any tool to take them all at once. The following code takes random text containing hex colour strings, and creates an HTML file of square colour swatches.

    #!/usr/bin/perl -w # # hextoswatch.pl - Extract colour strings from random code or HTML. # Currently only looks for 0xRRGGBB and #RRGGBB. # # perl hextoswatch.pl < source.txt > swatch.html # # and then open swatch.html in a browser! # # Chars that make up a colour string: # my $hexRegex = '0-9a-zA-Z'; my $colRegex = "#x$hexRegex"; my @hexSs = (); while ( <STDIN> ) { chomp; my @words = split /[^$colRegex]/; push @hexSs, (grep /^(0x|#)[$hexRegex]{6}$/, @words); } map { s/^(0x|#)(......)/$2/ } @hexSs; #print "Content-type: text/html\n\n"; print "<HTML>\n\n"; print "<HEAD>\n"; print "<TITLE>Colour swatches from random text</TITLE>\n"; print "</HEAD>\n\n"; print "<BODY><TABLE BORDER=1>\n"; print "<TR>"; my $cell = 0; foreach my $hex ( @hexSs ) { print "<TD BGCOLOR='#$hex'>", "<FONT COLOR='white'>$hex</FONT><BR><BR>", "<FONT COLOR='black'>$hex</FONT></TD>"; if ( $cell++ gt 4 ) { $cell=0; print "</TR>\n</TR>" } } print "</TR></TABLE></BODY></HTML>\n";
How RPi::WiringPi suite is automagically unit tested
1 direct reply — Read more / Contribute
by stevieb
on Aug 17, 2017 at 20:57

    A while ago, we were talking about my desire to write a tutorial about "Perl and Raspberry Pi". To kick it off, I thought I'd write a blog post covering some of the aspects of how I ensure full automatic unit test coverage of the software, and its core functionality.

    I posted it over on my blog, so for now, I'm just going to link to it as it's just a one-off that I quickly put together. If anyone is interested in how this software is tested, have a look. If you have feedback, all the better. Questions? That's the best I could ask for.

    How RPi::WiringPi distribution gets tested

    -stevieb

Number Grid Fillin
3 direct replies — Read more / Contribute
by QM
on Aug 14, 2017 at 04:41
    Saw this idea recently. Wondered how susceptible it would be to a brute force approach.

    Given a square grid size N, and a list of numbers 2*N**2 2*N, find a fillin (like a crossword), and report the digits in the major diagonal (as an easy proof of solution).

    The reference in the spoiler took an hour or two to find the solution. I won't post the solution here, you'll have to do the work yourself.

    -QM
    --
    Quantum Mechanics: The dreams stuff is made of

Reading/writing Arduino pins over I2C with Perl
No replies — Read more | Post response
by stevieb
on Jul 23, 2017 at 14:25

    In today's episode of Cool Uses for Perl, loosely inspired by this thread, I'm going to show how to set up an Arduino (Uno in this test case) with a pseudo-register that allows toggling one if its digital pins on and off, and another pseudo-register to read an analog pin that the digital pin is connected to, over I2C. Because it's digital to analog, the only possible values of the analog read will be 0 (off) or 1023 (full on, ie. 5v). This is an exceptionally basic example, but with some thought, one can imagine the possibilities (read/write EEPROM, set PWM etc etc).

    We'll then use RPi::I2C to toggle the digital pin and read the analog pin over the I2C bus. Note I'm not using the encompassing RPi::WiringPi distribution in this case. The benefit to using that is to clean up Raspberry Pi's GPIO pins, which we aren't using any. In fact, any Linux device with I2C can be used for this example, I just so happen to be using one of my Pi 3 boards.

    First, the simple Arduino sketch. All I2C devices require putting themselves on the "wire" with a unique address. I'm using 0x04, which is how the Pi will identify the Arduino on the I2C bus.

    #include <Wire.h> // Arduino I2C address #define SLAVE_ADDR 0x04 // pseudo register addresses #define READ_A0 0x05 #define WRITE_D2 0x0A uint8_t reg = 0; void read_analog_pin (){ switch (reg){ case READ_A0: { __read_analog(A0); break; } } } void __read_analog (int pin){ int val = analogRead(pin); uint8_t buf[2]; // reverse endian so we're little endian going out buf[0] = (val >> 8) & 0xFF; buf[1] = val & 0xFF; Wire.write(buf, 2); } void write_digital_pin (int num_bytes){ reg = Wire.read(); // global register addr while(Wire.available()){ uint8_t state = Wire.read(); switch (reg){ case WRITE_D2: { digitalWrite(2, state); break; } } } } void setup(){ Wire.begin(SLAVE_ADDR); // set up the I2C callbacks Wire.onReceive(write_digital_pin); Wire.onRequest(read_analog_pin); // set up the pins pinMode(2, OUTPUT); pinMode(A0, INPUT); } void loop(){ delay(10000); }

    Now, I'll show a simple script that loops 10 times, toggling the digital pin then displaying the value from the analog pin. Arudino's Wire library sends data a byte at a time, so we have to do some bit manipulation to turn the two bytes returned in the read_block() call back together into a single 16-bit integer. I wrote the merge() sub to take care of this job.

    use warnings; use strict; use RPi::Const qw(:all); use RPi::I2C; use constant { ARDUINO_ADDR => 0x04, READ_REGISTER => 0x05, WRITE_REGISTER => 0x0A, }; my $device = RPi::I2C->new(ARDUINO_ADDR); for (0..9){ my (@bytes_read, $value); $device->write_byte(HIGH, WRITE_REGISTER); @bytes_read = $device->read_block(2, READ_REGISTER); $value = merge(@bytes_read); print "$value\n"; # 1023 $device->write_byte(LOW, WRITE_REGISTER); @bytes_read = $device->read_block(2, READ_REGISTER); $value = merge(@bytes_read); print "$value\n"; # 0 } sub merge { return ($_[0] << 8) & 0xFF00 | ($_[1] & 0xFF); }

    Output:

    1023 0 1023 0 1023 0 1023 0 1023 0 1023 0 1023 0 1023 0 1023 0 1023 0

    update: I must acknowledge Slava Volkov (SVOLKOV) for the actual XS code. Most of the low-level hardware code I've been working on over the last year has been wrapping C/C++ libraries, a decent chunk of it has had me following datasheets to write my own, but in this case, I bit the whole XS file from Device::I2C and just presented a new Perl face to it so it fit in under the RPi::WiringPi umbrella. It just worked.

Download free Microsoft ebooks, fun with Mojolicious and CSS selectors
No replies — Read more | Post response
by marto
on Jul 21, 2017 at 11:35

    I was made aware that Microsoft giving away free ebooks. Excuse the clickbaity page title, I have nothing to do with it. While people have posted wget scripts to download them all, it doesn't rename them so you end up with some random file names. I threw the script below together really quickly, consider it a cheap hacky but functional (no errors here) script. For each 'Category' it creates a directory, and uses Mojolicious/Mojo::UserAgent to get the page, parse what we need from it, download each file to the it's associated category directory, with the actual ebook name.

    Caveats:

    • Ensure you have an up to date Mojolicious installed (cpanm Mojolicious).
    • Copy the script below into it's own directory before running.
    • Not all ebooks are available in all formats. I just select the top one in the list. Most are PDF, some are epub or .doc
    #!/usr/bin/perl use strict; use warnings; no warnings 'utf8'; use Mojo::UserAgent; my $ebookURL = 'https://blogs.msdn.microsoft.com/mssmallbiz/2017/07/11/largest-free-m +icrosoft-ebook-giveaway-im-giving-away-millions-of-free-microsoft-ebo +oks-again-including-windows-10-office-365-office-2016-power-bi-azure- +windows-8-1-office-2013-sharepo/'; =head1 NAME ms-ebook-dl - Download free Microsoft ebooks =head1 DESCRIPTION A quick hack using L<Mojolicious> to download and properly name a bunc +h of free ebooks from Microsoft. =head1 INSTALLATION Ensure you have an up to date L<Mojolicious> installed: C<cpanm Mojolicious> Clone the repo: C<git clone https://github.com/MartinMcGrath/ms-ebook-dl> =head1 LICENSE This is released under the Artistic License. See L<perlartistic>. =head1 AUTHOR marto L<https://github.com/MartinMcGrath/> =head1 SEE ALSO L<http://perlmonks.org/?node_id=1195726> L<https://blogs.msdn.microsoft.com/mssmallbiz/2017/07/11/largest-free- +microsoft-ebook-giveaway-im-giving-away-millions-of-free-microsoft-eb +ooks-again-including-windows-10-office-365-office-2016-power-bi-azure +-windows-8-1-office-2013-sharepo/> =cut my $ua = Mojo::UserAgent->new; print "Get page\n"; my $res = $ua->get( $ebookURL )->res; # css selector we want the first table witin the entry-content div, sk +ipping # the first row which is a header, but not a 'th' tag. my $selector = 'div.entry-content table:first-of-type tr:not(:first-of +-type)'; warn "Parse page\n"; $res->dom->find( $selector )->each( sub{ my $category = $_->children->[0]->all_text; my $title = $_->children->[1]->all_text; my $url = $_->children->[2]->at('a')->attr('href'); my $type = $_->children->[2]->at('a')->all_text; # download each file print "downloading: $title\n"; # create category directory unless it already exists mkdir $category unless( -d $category ); $ua->max_redirects(5) ->get( $url ) ->result->content->asset->move_to($category . '/' . $title . '.' + . $type); # play nice sleep(7); });

    Update: code updated with some POD, also on on github.

Using a controllerless servo on the Raspberry Pi with Perl
2 direct replies — Read more / Contribute
by stevieb
on Jul 08, 2017 at 17:03

    I've received quite a few pieces of great feedback from a variety of people since posting about writing my Perl/Raspberry Pi tutorial, and a lot of good has come from that feedback already.

    One person who pointed out one minor mistake of mine with follow up with some other questions, asked about how to run a servo without needing a controller board. I realized that I hadn't exposed a couple of functions in the core WiringPi::API distribution that allowed a user to configure the PWM frequency, which is required as the Pi default doesn't play nice with typical servos.

    The default PWM base frequency on a Pi is 19.2MHz, which is then divided by the clock signal (default: 32) and the PWM range (0-1023). So to get the default operating frequency:

    # base range clck operational freq 19.2e6 / 1024 / 32 == 586Hz

    To get this down to 50Hz required for a typical servo, I bumped up the range to 2000 (nice round number), and then just bounced around with the clock signal divider until I hit 50:

    19.2e6 / 2000 / 192 == 50Hz

    To be honest, I found the formula online, but then read through the datasheet for the Pi, and went on my way to not just copy and paste, but figure out exactly what frequency meant, what the divisors meant and then felt comfortable knowing exactly how PWM works ;)

    So, for full left, the servo requires a pulse of 50Hz for ~1ms (PWM 50), centre is ~1.5ms (PWM 150) and full right is ~2.5ms (PWM 250). My servo required me to tweak these numbers a tiny bit to get the full 180 degree motion.

    Anyway, to some code. I've commented the code as to what's happening and when, but an overall is that when started, the servo will go full-left, wait a sec, then swing from left-to-right, then back right-to-left until a SIGINT (CTRL-C) is caught, at which time, it puts the servo back to left position, then puts the pin back to INPUT mode so that if a different software is run after, the pin won't still be in PWM mode.

    Unfortunately, at this time, we still require sudo for PWM functionality. It's being looked at. It's the *only* thing left that requires root.

    use warnings; use strict; use RPi::WiringPi; use RPi::WiringPi::Constant qw(:all); die "need root!\n" if $> !=0; use constant { LEFT => 60, RIGHT => 255, CENTRE => 150, PIN => 18, DIVISOR => 192, RANGE => 2000, DELAY => 0.001, }; # set up a signal handler for CTRL-C my $run = 1; $SIG{INT} = sub { $run = 0; }; # create the Pi object my $pi = RPi::WiringPi->new; # create a signal pin, set mode to PWM output my $s = $pi->pin(PIN); $s->mode(PWM_OUT); # configure PWM to 50Hz for the servo $pi->pwm_mode(PWM_MODE_MS); $pi->pwm_clock(DIVISOR); $pi->pwm_range(RANGE); # set the servo to left max $s->pwm(LEFT); sleep 1; while ($run){ for (LEFT .. RIGHT){ # sweep all the way left to right $s->pwm($_); select(undef, undef, undef, DELAY); } sleep 1; for (reverse LEFT .. RIGHT){ # sweep all the way right to left $s->pwm($_); select(undef, undef, undef, DELAY); } sleep 1; } # set the pin back to INPUT $s->pwm(LEFT); $s->mode(INPUT);

    It won't be until later today after I get some extra tests written and update a couple of other items that are lingering, but it is available on Github for now.

    Note that the Pi may struggle to power the servo and it may cause a low-voltage situation, so it's best you power your 5v servo from an alternate source (I just happen to have a few powered-up Arduino's nearby all with 5v pins accessible). Also note that even though the +/- of the servo is 5v, you can safely connect the signal pin on it to the 3.3v GPIO on the Pi as on the servo, the pin is input only (ie. it doesn't feed back to the Pi).

Two small programs for comment
3 direct replies — Read more / Contribute
by Jambo Hamon
on Jul 07, 2017 at 08:10

    Two small programs. Just putting it out there for anyone who might be interested.

    First one posted generates the lexicographic ordering of balanced parenthesis. Second one finds the least number of block moves to turn one string into another string.

    Both are just initial sketches but I think they do what they should.

    $ perl balanced.pl 3 ()()() ()(()) (())() (()()) ((())) $ perl lcs.pl jamon hamon p=1 q=1 l=4 $ perl lcs.pl abcdef acdegh p=0 q=0 l=1 p=2 q=1 l=3
    #!/usr/bin/perl =begin Algorithm taken from: TAOCP - D.Knuth Vol 4 Fascicle 4 Generating All Trees History of Combinatorial Generation Algorithm P (Nested parenthesis in lexicographic order) =cut use strict; use warnings; use v5.10; my $n = shift || die "$!: need size"; my ( $l, $r ) = qw! ( ) !; my $m; ( $m, my @a ) = init( $n, $m ); my $j; while (1) { visit(@a); ( $m, @a ) = easy( $m, @a ); next if ( $a[$m] eq $l ); ( $m, $j, @a ) = findj( $m, @a ); last if ( $j == 0 ); ( $m, @a ) = incj( $m, $j, @a ); } sub easy { my $m = shift; my @a = @_; $a[$m] = $r; if ( $a[ $m - 1 ] eq $r ) { $a[ $m - 1 ] = $l, $m--; } return $m, @a; } sub incj { my $m = shift; my $j = shift; my @a = @_; $a[$j] = $l; $m = 2 * $n - 1; return $m, @a; } sub findj { my $m = shift; my @a = @_; my $j = $m - 1; my $k = 2 * $n - 1; while ( $a[$j] eq $l ) { $a[$j] = $r, $a[$k] = $l, $j--, $k -= 2; } return $m, $j, @a; } sub init { my $n = shift; my $m = shift; $m = 2 * $n - 1; my @a; for my $k ( 1 .. $n ) { @a[ 2 * $k - 1, 2 * $k ] = ( $l, $r ); } $a[0] = $r; return $m, @a; } sub visit { shift; print @_, "\n"; }
    #!/usr/bin/perl =begin How many block moves does it take to transform one string to another? algorithm taken from: the string-to-string correction probem by Walter F. Tichy ACM Transactions on Computer Systems Vol 2 No 4 Number 1984 p. 309-321 =cut use strict; use warnings; use v5.10; my @s = split //, shift || "shanghai rulez"; my @t = split //, shift || "sakhalin rulez"; # lengths my $n = $#t; my $m = $#s; my ( $p, $q, $l ) = ( 0, 0, 0 ); while ( $q <= $n ) { ( $p, $l ) = f($q); printf( "p=%d\tq=%d\tl=%d\n", $p, $q, $l ) if ( $l > 0 ); $q = $q + ( 1, $l )[ 1 < $l ]; # max(1,l) ... Perlmonks } sub f { my ($q) = @_; my $pCur = 0; my $l = 0; my $p = 0; while ( ( $pCur + $l <= $m ) and ( $q + $l <= $n ) ) { my $lCur = 0; while ( ( $pCur + $lCur <= $m ) and ( $q + $lCur <= $n ) and ( $s[ $pCur + $lCur ] eq $t[ $q + $lCur ] ) ) { $lCur++; } if ( $lCur > $l ) { $l = $lCur; $p = $pCur; } $pCur++; } return ( $p, $l ); }

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.