view release on metacpan or  search on metacpan

lib/Metabrik/Core/Context.pm  view on Meta::CPAN

   $dirpattern =~ s/\//\\\//g;

   my $dir_regex = qr/$dirpattern/;
   my $file_regex = qr/$filepattern/;
   my $dot_regex = qr/^\.$/;
   my $dot2_regex = qr/^\.\.$/;

   my @files = ();

   my $sub = sub {
      my $dir = $File::Find::dir;
      my $file = $_;
      # Skip dot and double dot directories
      if ($file =~ $dot_regex || $file =~ $dot2_regex) {
      }
      elsif ($dir =~ $dir_regex && $file =~ $file_regex) {
         push @files, "$dir/$file";
      }
   };

   {
      no warnings;
      File::Find::find($sub, @$path_list);
   };

   my %uniq_files = map { $_ => 1 } @files;
   @files = map { s/^\.\///; $_ } @files;  # Remove leading dot slash
   @files = sort { $a cmp $b } keys %uniq_files;

   return \@files;
}

sub find_available {
   my $self = shift;

   # Read from @INC, exclude current directory
   my @path_list = ();
   for (@INC) {
      next if /^\.$/;
      push @path_list, $_;
   }

   my $found = $self->_file_find(\@path_list);

   my %available = ();
   for my $this (@$found) {
      my $brik = $this;
      $brik =~ s{/}{::}g;
      $brik =~ s/^.*::Metabrik::(.*?)$/$1/;
      $brik =~ s/.pm$//;
      if (length($brik)) {
         my $module = "Metabrik::$brik";
         $brik = lc($brik);
         $available{$brik} = $module;
      }
   }

   return \%available;
}

sub update_available {
   my $self = shift;

   my $h = $self->find_available;

   my $r = $self->call(sub {
      my %args = @_;

      my $__ctx_available = $args{available};

      for my $__ctx_this (keys %$__ctx_available) {
         eval("require ".$__ctx_available->{$__ctx_this});
      }

      return $CON->{available} = $args{available};
   }, available => $h);

   return $r;
}

sub use {
   my $self = shift;
   my ($brik) = @_;

   if (! defined($brik)) {
      return $self->log->error($self->brik_help_run('use'));
   }

   my $r = $self->call(sub {
      my %args = @_;

      my $__ctx_brik = $args{brik};

      my $ERR = 0;
      my $USE = 'undef';

      my $__ctx_brik_repository = '';
      my $__ctx_brik_category = '';
      my $__ctx_brik_module = '';

      if ($__ctx_brik =~ /^[a-z0-9]+::[a-z0-9]+$/) {
         ($__ctx_brik_category, $__ctx_brik_module) = split('::', $__ctx_brik);
      }
      elsif ($__ctx_brik =~ /^[a-z0-9]+::[a-z0-9]+::[a-z0-9]+$/) {
         ($__ctx_brik_repository, $__ctx_brik_category, $__ctx_brik_module) = split('::', $__ctx_brik);
      }
      else {
         $ERR = 1;
         my $MSG = "use: invalid format for Brik [$__ctx_brik]";
         die("$MSG\n");
      }

      $CON->log->debug("repository[$__ctx_brik_repository]");
      $CON->log->debug("category[$__ctx_brik_category]");
      $CON->log->debug("module[$__ctx_brik_module]");

      $__ctx_brik_repository = ucfirst($__ctx_brik_repository);
      $__ctx_brik_category = ucfirst($__ctx_brik_category);
      $__ctx_brik_module = ucfirst($__ctx_brik_module);

      my $__ctx_module = 'Metabrik::'.(length($__ctx_brik_repository)