Sepia.pm

   1 package Sepia;
   2 our $VERSION = '0.56';
   3
   4 require Exporter;
   5 our @ISA = qw(Exporter);
   6
   7 use strict;
   8 use Cwd 'abs_path';
   9 use Module::Info;
  10 use B;
  11
  12 sub _apropos_re($)
  13 {
  14     # Do that crazy multi-word identifier completion thing:
  15     my $re = shift;
  16     if ($re !~ /[^\w\d_^:]/) {
  17         $re =~ s/(?<=[A-Za-z\d])([^A-Za-z\d])/[A-Za-z\\d]*$1+/g;
  18     }
  19     qr/$re/;
  20 }
  21
  22 =item C<completions($string)>
  23
  24 =cut
  25
  26 sub completions
  27 {
  28     no strict;
  29     my ($str, $pack) = @_;
  30     if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
  31         my @nameparts = split /:+/, $name;
  32         if (@nameparts == 1 && $pack) {
  33             @nameparts = (split(/:+/, $pack), $name);
  34         }
  35         local *_completions = sub {
  36             no strict;
  37             my ($stash, $part, @rest) = @_;
  38             $part = join '[^_]*_', split /_/, $part;
  39             $part = _apropos_re($part);
  40             if (@rest) {
  41                 map {
  42                     _completions("$stash$_", @rest)
  43                 } grep /^$part.*\::$/, keys %$stash;
  44             } else {
  45                 map { "$stash$_" } grep /^$part/, keys %$stash;
  46             }
  47         };
  48
  49         my $type = ($pfx eq '$' ? 'SCALAR'
  50                     : $pfx eq '@' ? 'ARRAY'
  51                     : $pfx eq '&' ? 'CODE'
  52                     : $pfx eq '%' ? 'HASH'
  53                     : undef);
  54         map {
  55             s/^::/$pfx/;$_
  56         } grep {
  57             !$type || defined(*{$_}{$type})
  58         } _completions('::', @nameparts);
  59     }
  60 }
  61
  62 =item C<location($name)>
  63
  64 =cut
  65
  66 sub location
  67 {
  68     no strict;
  69     map {
  70         my $str = $_;
  71         if (my ($pfx, $name) = $str =~ /^([\%\$\@]?)(.+)/) {
  72             if ($pfx) {
  73                 print STDERR "Sorry -- can't lookup variables.";
  74                 [];
  75             } else {
  76                 my $cv = B::svref_2object(\&{$name});
  77                 if ($cv && ($cv = $cv->START) && !$cv->isa('B::NULL')) {
  78                     my ($file, $line) = ($cv->file, $cv->line);
  79                     if ($file !~ /^\//) {
  80                         for (@INC) {
  81                             if (-f "$_/$file") {
  82                                 $file = "$_/$file";
  83                                 last;
  84                             }
  85                         }
  86                     }
  87                     my ($shortname) = $name =~ /^(?:.*::)([^:]+)$/;
  88                     [Cwd::abs_path($file), $line, $shortname]
  89                 } else {
  90                     [];
  91                 }
  92             }
  93         }
  94     } @_
  95 }
  96
  97 =item C<apropos($name [, $is_regex])>
  98
  99 =cut
 100
 101 sub apropos
 102 {
 103     no strict;
 104     my ($it, $re) = @_;
 105     if ($it =~ /^(.*::)([^:]+)$/) {
 106         my ($stash, $name) = @_;
 107         if ($re) {
 108             my $name = qr/$name/;
 109             map {
 110                 "$stash$name"
 111             }
 112             grep {
 113                 /$name/ && defined &{"$stash$name"}
 114             } keys %$stash;
 115         } else {
 116             defined &$it ? $it : ();
 117         }
 118     } else {
 119         my @ret;
 120         my $findre = $re ? qr/$it/ : qr/^\Q$it\E$/;
 121         print STDERR "Searching for $findre...";
 122         my_walksymtable {
 123             push @ret, "$stash$_" if /$findre/;
 124         } '::';
 125         map { s/^:://;$_ } @ret;
 126     }
 127 }
 128
 129 sub my_walksymtable(&*)
 130 {
 131     no strict;
 132     my ($f, $st) = @_;
 133     local *_walk = sub {
 134         local ($stash) = @_;
 135         &$f for keys %$stash;
 136         _walk("$stash$_") for grep /(?<!main)::$/, keys %$stash;
 137     };
 138     _walk($st);
 139 }
 140
 141 =item C<mod_subs($pack)>
 142
 143 Find subs in package C<$pack>.
 144
 145 =cut
 146
 147 sub mod_subs
 148 {
 149     no strict;
 150     my $p = shift;
 151     my $stash = \%{"$p\::"};
 152     if (defined $stash) {
 153         grep { defined &{"$p\::$_"} } keys %$stash;
 154     }
 155 }
 156
 157 =item C<mod_decls($pack)>
 158
 159 Generate a list of declarations for all subroutines in package
 160 C<$pack>.
 161
 162 =cut
 163
 164 sub mod_decls
 165 {
 166     my $pack = shift;
 167     no strict 'refs';
 168     my @ret = map {
 169         my $sn = $_->[2];
 170         my $proto = prototype(\&{"$pack\::$sn"});
 171         $proto = defined($proto) ? "($proto)" : '';
 172         "sub $sn $proto;\n";
 173     } mod_subs($pack);
 174     return wantarray ? @ret : join '', @ret;
 175 }
 176
 177 =item C<module_info($module, $type)>
 178
 179 Emacs-called function to get module information.
 180
 181 =cut
 182
 183 sub module_info($)
 184 {
 185     my ($m, $func) = @_;
 186     my $info;
 187     if (-f $m) {
 188         $info = Module::Info->new_from_file($m);
 189     } else {
 190         (my $file = $m) =~ s|::|/|g;
 191         $file .= '.pm';
 192         if (exists $INC{$file}) {
 193             $info = Module::Info->new_from_loaded($m);
 194         } else {
 195             $info = Module::Info->new_from_module($m);
 196         }
 197     }
 198     if ($info) {
 199         return $info->$func;
 200     }
 201 }
 202
 203 1;