use 5.006; # our use strict; use warnings; package CPAN::Testers::TailLog; our $VERSION = '0.001001'; our $DISTNAME = 'CPAN-Testers-TailLog'; # ABSTRACT: Extract recent test statuses from metabase log # AUTHORITY sub new { my $buildargs = { ref $_[1] ? %{ $_[1] } : @_[ 1 .. $#_ ] }; my $class = ref $_[0] ? ref $_[0] : $_[0]; my $self = bless $buildargs, $class; $self->_check_cache_file if exists $self->{cache_file}; $self->_check_url if exists $self->{url}; $self; } sub cache_file { $_[0]->{cache_file} = $_[0]->_build_cache_file unless exists $_[0]->{cache_file}; $_[0]->{cache_file}; } sub get_all { # If this fails, we just parse what we parsed last time # Actually, not sure if mirror is atomic or not. # Mirror is used here also to get automatic if-modified behaviour $_[0]->_ua->mirror( $_[0]->url, $_[0]->cache_file ); # So if the connection goes away and HTTP::Tiny fubars, # we just pretend things are fine for now. # mostly, because deciding how to handle error cases hurt # my tiny brain require Path::Tiny; my (@lines) = Path::Tiny::path( $_[0]->cache_file )->lines_utf8( { chomp => 1 } ); # Skip prelude shift @lines while @lines and $lines[0] !~ /\A\s*\[/; [ map { $_[0]->_parse_line($_) } @lines ]; } sub get_iter { my $self = $_[0]; my $fetched = 0; my $handle; my $done; return sub { return undef if $done; $fetched ||= do { $self->_ua->mirror( $self->url, $self->cache_file ); 1; }; defined $handle or $handle = do { require Path::Tiny; $handle = Path::Tiny::path( $self->cache_file )->openr_utf8; }; while ( my $line = <$handle> ) { next if $line !~ /\A\s*\[/; chomp $line; return $self->_parse_line($line); } $done = 1; return undef; }; } sub url { $_[0]->{url} = $_[0]->_build_url unless exists $_[0]->{url}; $_[0]->{url}; } # -- private ] -- sub _parse_line { my %record; @record{ qw( submitted reporter grade filename platform perl_version uuid accepted ) } = ( $_[1] =~ qr{ \A \s* \[ (.*? ) \] # submitted \s* \[ (.*? ) \] # reported \s* \[ (.*? ) \] # grade \s* \[ (.*?) \] # filename \s* \[ (.*?) \] # platform \s* \[ (.*?) \] # perl_version \s* \[ (.*?) \] # uuid \s* \[ (.*?) \] # accepted }x ); require CPAN::Testers::TailLog::Result; CPAN::Testers::TailLog::Result->new( \%record ); } sub _ua { $_[0]->{_ua} = $_[0]->_build_ua unless exists $_[0]->{_ua}; $_[0]->{_ua}; } # -- builders ] -- sub _build_cache_file { require File::Temp; my $temp = File::Temp->new( TEMPLATE => $DISTNAME . '-XXXXX', TMPDIR => 1, SUFFIX => '.txt', EXLOCK => 0, ); $_[0]->{_tempfile} = $temp; require Path::Tiny; # Touching tempfiles required to get useful if-modified behaviour Path::Tiny::path( $temp->filename )->touch( time - ( 7 * 24 * 60 * 60 ) ); $temp->filename; } sub _build_ua { require HTTP::Tiny; HTTP::Tiny->new( agent => ( $DISTNAME . '/' . $VERSION ), ); } sub _build_url { 'http://metabase.cpantesters.org/tail/log.txt'; } # -- checkers ] -- sub _check_cache_file { require Path::Tiny; my $path = Path::Tiny::path( $_[0]->{cache_file} ); my $dir = $path->parent; die "cache_file: Directory for $path not accessible: $?" unless -e $dir and -d $dir and -r $dir; if ( not -e $path ) { # Path doesn't exist, test creating it # Hope touch dies if it can't be written $path->touch( time - ( 7 * 24 * 60 * 60 ) ); } return if -e $path and not -d $path and -w $path; die "cache_file: $path exists but is unwriteable"; } sub _check_url { die "url: Missing protocol in $_[0]->{url}" if $_[0]->{url} !~ qr{://}; die "url: Unknown protocol in $_[0]->{url}" if $_[0]->{url} !~ qr{\Ahttps?://}; } 1; =head1 NAME CPAN-Testers-TailLog - Extract recent test statuses from metabase log =head1 SYNOPSIS use CPAN::Testers::TailLog; my $tailer = CPAN::Testers::TailLog->new(); my $results = $tailer->get_all(); for my $item ( @{ $results } ) { printf "%s: %s\n", $item->grade, $item->filename; } =head1 DESCRIPTION B is a simple interface to the C C located at C This module simply wraps the required HTTP Request mechanics, some persistent caching glue for performance, and a trivial parsing layer to provide an object oriented view of the log. =head1 METHODS =head2 new Creates an object for fetching results. my $tailer = CPAN::Testers::TailLog->new( %options ); =head3 new:cache_file ->new( cache_file => "/path/to/file" ) If not specified, defaults to a C file. This is good enough for in-memory persistence, so for code that is long lived setting this is not really necessary. However, if you want a regularly exiting process, like a cron job, you'll probably want to set this to a writeable path. This will ensure you save redundant bandwidth if you sync too quickly, as the C will be used for C. Your C calls will still look the same, but they'll be a little faster, you'll eat a little less bandwidth, and stress the remote server a little less. =head3 new:url ->new( url => "http://path/to/tail.log" ) If not specified, uses the default URL, http://metabase.cpantesters.org/tail/log.txt Its not likely you'll have a use for this, but it may turn out useful for debugging, or maybe somebody out there as an equivalent private server with this log. =head2 cache_file Accessor for configured cache file path my $path = $tailer->cache_file =head2 get_all Fetches the most recent data possible as an C of L my $arrayref = $tailer->get_all(); Note that an arrayref will be returned regardless of what happens. It helps to assume the result is just a dumb transfer. Though keep in mind non-Cs may be returned in error conditions (Undecided). Calling this multiple times will be efficient using C headers where applicable. Though even if nothing has changed, you'll get a full copy of the last state. If you want an "only what's changed since last time we checked, see F =head2 get_iter Returns a lazy C that returns one L at a time. my $iter = $tailer->get_iter(); while ( my $item = $iter->() ) { printf "%s %s\n", $item->grade, $item->filename; } As with C, present design is mostly "dumb state transfer", so all this really serves is a possible programming convenience. However, optimisations may be applied here in future so that C<< $iter->() >> pulls items off the wire as they arrive, saving you some traffic if you terminate early. Presently, an early termination only saves you a little disk IO, extra regex parses and shaves a few object creations. =head2 url Accessor for configured log URL. my $url = $tailer->url; =head1 SEE ALSO =over 4 =item * L Some of the logic of this module shares similarity with the contents of that module, however, that module is designed as a standalone application that simply shows the current status with some filtration options. It is not however designed for re-use. My objective is different, and I want to write a daemon that periodically polls for new records, and creates a local database ( Similar to what likely happens inside C ) of reports for quick searching, and I figure this sort of logic can also be useful for somebody who wants a C monitor. Some of the logic was cribbed from this and reduced to be closer to verbatim. =item * L C contains similar logic to this script as well, again, prioritizing for simplicity and re-use. Any specific mangling with C is left to the consumer. =back =head1 AUTHOR Kent Fredric =head1 LICENSE This software is copyright (c) 2016 by Kent Fredric. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.