view release on metacpan or  search on metacpan

Report.pm  view on Meta::CPAN

package Aviation::Report;

use strict;

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);

require Exporter;

@ISA = qw(Exporter AutoLoader);
# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.
@EXPORT = qw(
	decode_METAR_TAF decode_PIREP
);
$VERSION = '1.02';

   my %abb = ();

   while (<DATA>) {
      chomp;
      next if /^#?$/;
      my ($abbrev, $desc) = split /:/;
      $abb{$abbrev} = $desc;
   }

   my @low = ('None', 'Cumulus  (fair wx)', ' Cumulus (towering)', 'Cumulonimbus (no anvil)', 'Stratocumulus', 'Stratocumulus', 'Stratus', 'Fractocumulus/Fractostratus', 'Cumulus and Stratocumulus', 'Cumulonimbus');

   my @middle = ('None', 'Altostratus (thin)', 'Altostratus (thick)', 'Altocumulus (thin)', 'Altocumulus (patchy)', 'Altocumulus (thickening)', 'Altocumulus (from Cumulonimbus)', 'Altocumulus (w/Ac,As,Ns)', 'Altocumulus (w/turrets)', 'Altocumulus (ch...

   my @high = ('None', 'Cirrus (filaments)', 'Cirrus (dense)', 'Cirrus (often w/Cb)', 'Cirrus (thickening)', 'Cirrus/Cirrostratus (low in sky)', 'Cirrus/Cirrostratus (high in sky)', 'Cirrostratus (entire sky)', 'Cirrostratus (partial)', 'Cirrocumulus...

   my %abb_pirep = ( UA => 'routine pilot report',
                     UUA => 'urgent pilot report',
                     OV => 'location',
                     TM => 'time',
                     FL => 'altitude',
                     TP => 'type of aircraft',
                     SK => 'sky cover',
                     WX => 'weather',
                     TA => 'temperature',
                     WV => 'wind',
                     TB => 'turbulence',
                     IC => 'icing',
                     RM => 'remarks',
                     CLR => 'clear',
                     LGT => 'light',
                     MDT => 'moderate',
                     HVY => 'heavy',
   );
1;

sub decode_PIREP {
   my ($s, $style) = @_;
   my $s = uc $s;
   my ($out) = $s . "\n" if $style;

   my $token;

   my @tokens = split m:/:, $s;

   while ($token = shift @tokens) {
         my ($element, $value) = ('', '');
         if (($element, $value) = split / /, $token, 2) {
            if (exists $abb_pirep{$element}) {
               $out .= $abb_pirep{$element} . ' ';
            }
            else {
               if ($element =~ /^(\d{3})$/) {
                  $out .= int($1)."00 feet ";
                  foreach (split / /, $value) {
                     if (/^(\d{3})$/) {
                        $out .= int($1)."00 feet ";
                     }
                     elsif (/^([A-Z]+)$/) {
                        if (exists $abb{$1}) {
                           $out .= $abb{$1} . ' ';
                        }
                        else {
                           $out .= $1 . ' ';
                        }
                     }
                     else {
                        $out .= $_;
                     }
                  }
               }
               else {
                  $out .= $element;
               }
               $out .= "\n";
               next;
            }
            if ($element eq 'IC' or $element eq 'TB') {
               if (exists $abb_pirep{$value}) {
                  $out .= $abb_pirep{$value};
               }
               else {
                  $out .= $value;
               }
            }
            elsif ($element eq 'OV' and $value =~ /^(.*?) (\d{3})(\d{3})$/) {
               $out .= int($2) ." nautical miles on the $3 degree radial from $1";
            }
            elsif ($element eq 'SK') {
               foreach (split / /, $value) {
                  if (/^(\d{3})$/) {
                     $out .= int($1)."00 feet msl ";
                  }
                  elsif (/^([A-Z]+)$/) {
                    if (exists $abb{$1}) {
                       $out .= $abb{$1};
                    }
                    else {
                       $out .= $1;
                    }
                  }
                  else {
                     $out .= $_;
                  }