view release on metacpan or  search on metacpan

lib/PDL/Demos.pm  view on Meta::CPAN

package PDL::Demos;

use strict;
use warnings;
use Carp;
use Exporter;
require File::Spec;

our @ISA="Exporter";
our @EXPORT = qw/comment act actnw/;

sub comment($) {
   local $SIG{__DIE__} = \&Carp::confess;
   print "----\n";
   print $_[0];
   my $prompt = "---- (press enter)";
   defined($PERLDL::TERM) ? $PERLDL::TERM->readline($prompt) : ( print $prompt, <> );
}

sub act($) {
   local $SIG{__DIE__} = \&Carp::confess;
   actnw($_[0], (caller)[0]);
   my $prompt = "---- (press enter)";
   defined($PERLDL::TERM) ? $PERLDL::TERM->readline($prompt) : ( print $prompt, <> );
}

sub _eval_pkg {
  my ($txt, $pack) = @_;
  eval "package $pack; no strict; use PDL; $txt";
}
sub actnw($) {
   local $SIG{__DIE__} = \&Carp::confess;
   my ($script, $pack) = @_;
   print "---- Code:";
   print $script;
   print "---- Output:\n";
   _eval_pkg($script, $pack // (caller)[0]);
   print "----\n";
   print "----\nOOPS!!! Something went wrong, please make a bug report!: $@\n----\n" if $@;
}

my ($searched, @found);
my @d = qw(PDL Demos);
sub list {
  return @found if $searched;
  $searched = 1;
  my %found_already;
  foreach my $path ( @INC ) {
    next if !-d (my $dir = File::Spec->catdir( $path, @d ));
    my @c = do { opendir my $dirfh, $dir or die "$dir: $!"; grep !/^\./, readdir $dirfh };
    for my $f (grep /\.pm$/ && -f File::Spec->catfile( $dir, $_ ), @c) {
      $f =~ s/\.pm//;
      my $found_mod = join "::", @d, $f;
      next if $found_already{$found_mod}++;
      push @found, $found_mod;
    }
    for my $t (grep -d $_->[1], map [$_, File::Spec->catdir( $dir, $_ )], @c) {
      my ($subname, $subd) = @$t;
      # one extra level
      my @c = do { opendir my $dirfh, $subd or die "$subd: $!"; grep !/^\./, readdir $dirfh };
      for my $f (grep /\.pm$/ && -f File::Spec->catfile( $subd, $_ ), @c) {
        $f =~ s/\.pm//;
        my $found_mod = join "::", @d, $subname, $f;
        next if $found_already{$found_mod}++;
        push @found, $found_mod;
      }
    }
  }
  @found;
}

my ($kw_loaded, %kw2info); # info = [kw, description, module]
sub _load_keywords {
  return if $kw_loaded;
  $kw_loaded = 1;
  my @modules = grep eval "require $_; 1", __PACKAGE__->list;
  my %mod2i = map +($_ => [$_->info]), grep $_->can('info'), @modules;
  %kw2info = map +($mod2i{$_}[0] => [@{$mod2i{$_}}, $_]), keys %mod2i;
}
sub keywords { _load_keywords(); keys %kw2info; }
sub info {
  _load_keywords();
  my $info = $kw2info{$_[1]} || die "unknown demo $_[1]\n";
  @$info;
}
sub demo {
  my $pkg = ($_[0]->info($_[1]))[2];
  $pkg->can('demo') ? $pkg->demo : [comment=>"No demo data found for $_[1]\n"];
}
sub _proxy {
  my $method = shift;
  my $pkg = ($_[0]->info($_[1]))[2];
  return if !$pkg->can($method);
  _eval_pkg($pkg->$method, (caller 1)[0]);
}
sub init { _proxy('init', @_) }
sub done { _proxy('done', @_) }