package MOP4Import::Util;
use strict;
use warnings qw(FATAL all NONFATAL misc);
use Carp;
use Data::Dumper;
use Encode ();

use Exporter qw/import/;

use Sub::Util ();

use constant DEBUG => $ENV{DEBUG_MOP4IMPORT};
BEGIN {
  print STDERR "Using (file '" . __FILE__ . "')\n" if DEBUG and DEBUG >= 2
}

sub globref {
  my $pack = shift;
  unless (defined $pack) {
    Carp::croak "undef is given to globref()";
  }
  my $symname = join("::", $pack, @_);
  no strict 'refs';
  \*{$symname};
}

sub symtab {
  *{globref(shift, '')}{HASH}
}

sub maybe_symtab {
  my ($pack) = @_;
  my @name = split /::/, $pack
    or return undef;
  shift @name if $name[0] eq "";
  my $symtab = \%::;
  foreach my $name (@name) {
    my $glob = $symtab->{$name . "::"}
      or return undef;
    $symtab = *{$glob}{HASH}
      or return undef;
  }
  $symtab;
}

sub safe_globref {
  my ($pack_or_obj, $name) = @_;
  unless (defined symtab($pack_or_obj)->{$name}) {
    my $pack = ref $pack_or_obj || $pack_or_obj;
    croak "No such symbol '$name' in package $pack";
  }
  globref($pack_or_obj, $name);
}

sub maybe_globref {
  my ($pack_or_obj, $name) = @_;
  unless (defined symtab($pack_or_obj)->{$name}) {
    return undef;
  }
  globref($pack_or_obj, $name);
}

sub fields_hash {
  my $sym = fields_symbol(@_);
  # XXX: return \%{*$sym}; # If we use this, we get "used only once" warning.
  ensure_symbol_has_hash($sym);
}

sub maybe_fields_hash {
  my $sym = maybe_globref($_[0], 'FIELDS')
    or return undef;
  *{$sym}{HASH};
}

sub safe_fields_hash {
  my $sym = safe_globref($_[0], 'FIELDS');
  ensure_symbol_has_hash($sym);
}

sub fields_array {
  my $sym = fields_symbol(@_);
  ensure_symbol_has_array($sym);
}

sub fields_symbol {
  globref(ref $_[0] || $_[0], 'FIELDS');
}

#
# Just lock_keys with fields_hash
#
sub lock_keys_as {
  my ($myPack, $typeName, $hash) = @_;
  require Hash::Util;
  $hash //= +{};
  if (ref $typeName) {
    Carp::croak "Typename must be a package name: "
      . terse_dump($typeName);
  }
  my $fields = safe_fields_hash($typeName);
  if (not Hash::Util::hashref_locked($hash)) {
    Hash::Util::lock_ref_keys($hash, keys %$fields);
  } else {
    if (my @unk = grep {not exists $fields->{$_}}
        Hash::Util::legal_ref_keys($hash)) {
      Carp::croak "HASH contains illegal keys wrt type $typeName: "
        . join(" ", sort @unk);
    }
    # OK;
  }
  $hash;
}

sub isa_array {
  my $sym = globref($_[0], 'ISA');
  ensure_symbol_has_array($sym);
}

sub ensure_symbol_has_array {
  my ($sym) = @_;
  unless (*{$sym}{ARRAY}) {
    *$sym = [];
  }
  *{$sym}{ARRAY};
}

sub ensure_symbol_has_hash {
  my ($sym) = @_;
  unless (*{$sym}{HASH}) {
    *$sym = {};
  }
  *{$sym}{HASH};
}

sub define_constant {
  my ($name_or_glob, $value) = @_;
  my $glob = ref $name_or_glob ? $name_or_glob : globref($name_or_glob);
  *$glob = my $const_sub = sub () { $value };
  $const_sub;
}

# MOP4Import::Util::extract_fields_as(BASE_CLASS => $obj)
# => returns name, value pairs found in BASE_CLASS and defined in $obj.
# Note: this only extracts fields starting with [a-z].
sub extract_fields_as ($$) {
  my ($asPack, $obj) = @_;
  my $fields = fields_hash($asPack);
  map {
    if (/^[a-z]/ and defined $obj->{$_}) {
      ($_ => $obj->{$_})
    } else {
      ()
    }
  } keys %$fields
}

#
# For (shallow) copy constructor.
#
sub shallow_copy {
  if (ref $_[0] eq 'HASH') {
    +{%{$_[0]}};
  } elsif (ref $_[0] eq 'ARRAY') {
    +[@{$_[0]}];
  } elsif (ref $_[0] eq 'Regexp'
             or not ref $_[0]) {
    my $copy = $_[0];
  } elsif ($_[1]) {
    # Pass thru unknown refs if 2nd arg is true.
    $_[0];
  } else {
    croak "Unsupported data type for shallow_copy: " . ref $_[0];
  }
}

#
# Expand given item as list.
#
sub lexpand {
  if (not defined $_[0]) {
    return
  } elsif (ref $_[0] eq 'ARRAY') {
    @{$_[0]}
  } else {
    $_[0]
  }
}

sub terse_dump {
  join ", ", map {
    Data::Dumper->new([$_])->Terse(1)->Indent(0)->Dump;
  } @_;
}

#
# This may be useful to parse/take subcommand option/hash.
#
sub take_hash_opts_maybe {
  my ($pack, $list, $result, $alias) = @_;

  if (@$list and ref $list->[0] eq 'HASH') {
    # If first element of $list is HASH, take it.

    shift @$list;
  } else {
    # Otherwise, take --posix_style=options.

    $pack->parse_opts($list, $result, $alias);
  }
}

sub take_locked_opts_of {
  my ($myPack, $typeName, $list, $alias, $sink) = @_;
  $myPack->lock_keys_as($typeName, scalar take_hash_opts_maybe(
    $myPack,
    $list,
    $sink,
    $alias,
  ));
}

#
# posix_style long option.
#
sub parse_opts {
  my ($pack, $list, $result, $alias, $converter, %opts) = @_;
  my $wantarray = wantarray;
  unless (defined $result) {
    $result = $wantarray ? [] : {};
  }
  my $preserve_hyphen = delete $opts{preserve_hyphen} // do {
    my $sub = $pack->can("parse_opts__preserve_hyphen");
    $sub && $sub->($pack);
  };
  if (keys %opts) {
      Carp::croak("Unknown option for parse_opts(): ".join(", ", keys %opts));
  }
  while (@$list and defined $list->[0] and my ($n, $v) = $list->[0]
	 =~ m{^--$ | ^(?:--? ([\w:\-\.]+) (?: =(.*))?)$}xs) {
    shift @$list;
    last unless defined $n;
    $n =~ s/-/_/g unless $preserve_hyphen;
    $n = $alias->{$n} if $alias and $alias->{$n};
    $v = 1 unless defined $v;
    if (ref $result eq 'HASH') {
      $result->{$n} = $converter ? $converter->($v) : $v;
    } else {
      push @$result, $n, $converter ? $converter->($v) : $v;
    }
  }
  if ($converter) {
    $_ = $converter->($_) for @$list;
  }
  $wantarray && ref $result ne 'HASH' ? @$result : $result;
}

#
# posix_style long option with JSON support.
#
sub parse_json_opts {
  my ($pack, $list, $result, $alias) = @_;
  require JSON::MaybeXS;
  parse_opts($pack, $list, $result, $alias, sub {
    if (not defined $_[0]) {
      undef
    } elsif ($_[0] =~ /^(?:\[.*?\]|\{.*?\})\z/s) {
      # Arguments might be already decoded.
      my $copy = $_[0];
      Encode::_utf8_off($copy) if Encode::is_utf8($copy);
      JSON::MaybeXS::JSON()->new->utf8->relaxed->decode($copy);
    } elsif (not Encode::is_utf8($_[0]) and $_[0] =~ /\P{ASCII}/) {
      Encode::decode(utf8 => $_[0]);
    } else {
      $_[0];
    }
  });
}

#
# make style KEY=VALUE list
#
sub parse_pairlist {
  my ($pack, $aref, $do_box) = @_;
  my @res;
  while (@$aref and defined $aref->[0]
	 and $aref->[0] =~ /^([\w:\-\.]+)=(.*)/) {
    my $item = shift @$aref;
    push @res, $do_box ? [$1, $2] : ($1, $2);
  }
  @res;
}

sub function_names {
  my (%opts) = @_;
  my $packname = delete $opts{from}     // caller;
  my $pattern  = delete $opts{matching} || qr{^[A-Za-z]\w+$};
  my $except   = delete $opts{except}   // qr{^import$};
  my $grep     = delete $opts{grep};
  if (keys %opts) {
    croak "Unknown arguments: ".join(", ", keys %opts);
  }
  my $symtab = *{globref($packname, '')}{HASH};
  my @result;
  foreach (sort keys %$symtab) {
    my $item = $symtab->{$_};
    defined (my $code = ref $item eq 'CODE' ? $item :
             ref \$item eq 'GLOB' ? *{$item}{CODE} : undef)
      or next;
    my $realName = Sub::Util::subname($code);
    my ($stash) = $realName =~ m/^(.+)::(.*?)$/;
    next unless $stash eq $packname;
    next unless $_ =~ $pattern;
    next if $except and $_ =~ $except;
    next if $grep and not $grep->($realName, $code);
    push @result, $_;
  }
  @result;
}

#========================================

sub has_method_attr {
  grep {$_ eq 'method'} attributes::get($_[0])
}

use MOP4Import::FieldSpec qw(FieldSpec);

sub list_validator {
  my ($typeName) = @_;
  my $fields = maybe_fields_hash($typeName)
    or Carp::croak "Can't find type spec for $typeName";
  my $names = fields_array($typeName);
  my @names = $names ? @$names : sort keys %$fields;
  map {
    my FieldSpec $spec = $fields->{$_};
    if (not UNIVERSAL::isa($spec, FieldSpec)) {
      ()
    }
    elsif ($spec->{validator}) {
      ($_ => $spec->{validator})
    }
    elsif ($spec->{isa}) {
      ($_ => +{isa => $spec->{isa}, (exists $spec->{default} ? (default => $spec->{default}) : ())})
    }
    else {
      ()
    }
  } @names;
}

#========================================

sub m4i_log_start {
  my $m4i_meta = caller;
  my $m4i_dest = caller(1);
  print STDERR "\n", "START of $m4i_meta->import() for $m4i_dest.\n";
}

sub m4i_log_end {
  my ($m4i_dest) = @_;
  my $m4i_meta = caller;
  $m4i_dest //= caller(1);
  print STDERR "END of $m4i_meta->import() for $m4i_dest.\n\n";
}

our @EXPORT = qw/globref
		 safe_globref
		 fields_hash fields_symbol lexpand terse_dump
		 fields_array
                 m4i_log_start
                 m4i_log_end
		/;
our @EXPORT_OK = function_names(from => __PACKAGE__
		   , except => qr/^(import|c\w*)$/
		 );

1;
