view release on metacpan or  search on metacpan

lib/Perl/APIReference.pm  view on Meta::CPAN

$Perls{'5.022000'} = $Perls{5.022};
$Perls{'5.020'}    = $Perls{5.02};
$Perls{'5.020000'} = $Perls{5.02};
$Perls{'5.018000'} = $Perls{5.018};
$Perls{'5.016000'} = $Perls{5.016};
$Perls{'5.014000'} = $Perls{5.014};
$Perls{'5.012000'} = $Perls{5.012};
$Perls{'5.010000'} = $Perls{5.01};
$Perls{'5.010'}    = $Perls{5.01};
$Perls{'5.008000'} = $Perls{5.008};
$Perls{'5.006000'} = $Perls{5.006};
#$Perls{'5.000'} = $Perls{5};

sub _get_class_name {
  my $class_or_self = shift;
  my $version = shift;
  return exists $Perls{$version} ? "Perl::APIReference::" . $Perls{$version} : undef;
}

sub new {
  my $class = shift;
  my %args = @_;
  my $perl_version = $args{perl_version};
  croak("Need perl_version")
    if not defined $perl_version;
  $perl_version = $NewestStableAPI if lc($perl_version) eq "newest";
  $perl_version = $NewestAPI if lc($perl_version) eq "newest_devel";

  $perl_version = version->new($perl_version)->numify();
  croak("Bad perl version '$perl_version'")
    if not exists $Perls{$perl_version};

  my $classname = __PACKAGE__->_get_class_name($perl_version);
  eval "require $classname;";
  croak("Bad perl version ($@)") if $@;

  return $classname->new(perl_version => $perl_version);
}

sub as_yaml_calltips {
  my $self = shift;

  my $index = $self->index();
  my %toyaml;
  foreach my $entry (keys %$index) {
    my $yentry = {
      cmd => '',
      'exp' => $index->{$entry}{text},
    };
    $toyaml{$entry} = $yentry;
  }
  require YAML::Tiny;
  return YAML::Tiny::Dump(\%toyaml);
}

# only for ::Generator
sub _new_from_parse {
  my $class = shift;

  return bless {@_} => $class;
}

# only for ::Generator
sub _dump_as_class {
  my $self = shift;
  my $version = $self->perl_version;
  my $classname = $self->_get_class_name($version);
  if (not defined $classname) {
    die "Can't determine class name for Perl version '$version'."
      . " Do you need to add it to the list of supported versions first?";
  }
  my $file_name = $classname;
  $file_name =~ s/^.*::([^:]+)$/$1.pm/;
  
  require Sereal::Encoder;
  my $data = $self->{'index'};
  my $dump = Sereal::Encoder->new({
    canonical      => 1,
    compress       => Sereal::Encoder::SRL_ZLIB(),
    compress_level => 9,
    dedupe_strings => 1,
  })->encode($data);
  
  open my $fh, '>', $file_name or die $!;
  binmode $fh;
  print $fh <<HERE;
package $classname;
use strict;
use warnings;
use Sereal::Decoder;
use parent 'Perl::APIReference';

sub new {
  my \$class = shift;
  my \$pos = tell(*DATA);
  binmode(*DATA);
  local \$/ = undef;

  my \$data = <DATA>;
  \$data =~ s/^\\s+//;

  my \$self = bless({
    'index'      => Sereal::Decoder::decode_sereal(\$data),
    perl_version => '$version',
  } => \$class);

  seek(*DATA, \$pos, 0);

  return \$self;
}

1;

HERE
  print $fh "__DATA__\n";
  print $fh $dump;
}


1;