view release on metacpan or  search on metacpan

DB.IN  view on Meta::CPAN

	@chunk=();
	$csz=0;
	++$chunk;
    };
    while (@var) {
	my $c = shift @var;
	&$save_chunk if @chunk && length($c) + $csz > $MAX_VAR_LENGTH;
	push @chunk, $c;
	$csz += length $c;
    }
    &$save_chunk if @chunk;
}

# put a var back together if it was split due
# to being too large for the shell to handle
sub join_variable { # PRIVATE
    my ($o,$k) = @_;
    return if exists $o->{env}{$k};
    my @c;
    for (my $c=1; exists $o->{env}{"$k$c"}; $c++){
	push @c, $o->{env}{"$k$c"};
	delete $o->{env}{"$k$c"};
    }
    $o->{env}{$k} = join(':', @c) || '';
}

sub interpolate {
    my ($o, $qx, $str) = @_;
    my $subst = sub {
	my $var = shift;
	$var =~ tr [{}] []d;
	# removed deprecated XXX
	if ($var eq 'MODULE_BASE' or $var eq 'modulebase' or
	    $var eq 'ENVY_LINKBASE') {
	    $o->w("$var is deprecated")
		if $var =~ /module/i;
	    return tree_top($Path);
	} elsif ($var eq 'MODULE_REALBASE' or $var eq 'ENVY_BASE') {
	    $o->w("$var is deprecated")
		if $var =~ /module/i;
	    my $rbase = $Path;
	    while (-l $rbase) {
		my $link = readlink($rbase) or die "readlink $rbase";
		if ($link =~ m,^/,) {
		    $rbase = $link    # absolute path
		} else {
		    # collapse ../
		    $rbase =~ s,/([^/]+)$,/,;
		    my $envy = $1;
		    $link =~ s,/.+?$,/,;
		    while ($link =~ s,\.\./$,,) {
			$rbase =~ s,/[^/]+/$,/,;
		    }
		    $rbase .= $link . $envy;
		}
	    }
	    return tree_top($rbase);
	} elsif ($var =~ m/^ENVY_(R|E)UID([_\w]*)$/) {
	    my $id = $1 eq 'R'? $< : $>;
	    my $field = $2;
	    my $pw = $PASSWD{$id} ||= [getpwuid($id)];
	    my $got = do {
		if ($field eq '') {
		    $id
		} elsif ($field eq '_NAME') {
		    $pw->[0]
		} elsif ($field eq '_GID') {
		    $pw->[3]
		} elsif ($field eq '_GCOS') {
		    $pw->[6]
		} elsif ($field eq '_DIR') {
		    $pw->[7]
		} elsif ($field eq '_SHELL') {
		    $pw->[8]
		} else {
		    $o->w("Builtin '$var' unrecognized");
		    ''
		}
	    };
	    return $got;
	}
	return $o->e("Variable '$var' unset for interpolation"), '' if
	    !defined $o->{env}{$var};
	$o->{env}{$var};
    };
    # need to do real lexical analysis XXX
    if($str =~ /^\'(.*)\'$/){
	return $1;
    }
    if($str =~ /\`(.*)\`$/){
      my(@asBackTic) = `$1`;
      chomp(@asBackTic);
      my($sBackTic) = join(" ",@asBackTic);
      $str =~ s/\`(.*)\`/$sBackTic/;
    }
    while ($str =~ s/
	   \$ (
	       (:? \{[\w-]+\} ) |
	       (:?   [\w-]+   )
	       )
	   /&$subst($1)/exg) {};
    $str;
}

sub edit_key {
    my ($o, $k) = @_;
    if ($k eq 'MODULE_PATH') {
	$o->w("'$k' is deprecated; please use ".&PATH);
	$k = &PATH;
    }
    return $o->w("Variable '$k' is not alpha-numeric") if
	$k !~ /^[\w-]+$/;
    return $o->w("Naughty: '$k' is private") if
	($k eq &STATE or $k eq &DIMENSION or
	 $k eq 'ENVY_BASE' or $k eq 'ENVY_LINKBASE');
    $k;
}

sub assign {
    my ($o, $reverse, $k, $force, $v) = @_;
    $k = $o->edit_key($k);

DB.IN  view on Meta::CPAN

	elsif ($l =~ /^([\w-]+) (\+\=|\=\+) (.*)$/x) {
	    my @got = ($1, $2 eq '+=', ':', $3);
	    $prechange->();
	    if ($got[0] eq &PATH) {
		if ($is_first) {
		    $o->w("In First, '".&PATH."' must be assigned with =")
		}
		if ($got[1]) {
		    $o->w("Variable '".&PATH."' cannot be prepended")
		}
		$got[1] = 0;
	    }
	    $o->rejoin($how<0, @got)
		if $mod;
	    $o->search_envy_path if $got[0] eq &PATH;

	} elsif ($l =~ /^([\w-]+) (:)?= (.*)$/x) {
	    my @got = ($1,$2,$3);
	    $prechange->();
	    if (!$is_first and $got[0] eq &PATH) {
		$o->w("Variable '".&PATH."' must be edited with +=")
	    }
	    $o->assign($how<0, @got)
		if $mod;
	    $o->search_envy_path if $got[0] eq &PATH;

	} else {
	    # Newer version of envy knows about new tokens...?
	    $o->n("Inexplicable '$l' (ignored)");
	}
    };

    if ($how>=0) {
	for (my $line_no = 1; $line_no <= @L; $line_no++) {
	    $doline->($line_no);
	    last if $o->{errors} > 5;
	}
	if ($how) {
	    if ($is_first and !$o->{env}{&PATH}) {
		$o->w("You must set '".&PATH."'")
	    }
	    if ($swap and $swap != 1) {
		$o->set_refcnt($e, $swap)
	    } else {
		$o->refcnt_inc($e, $by);
	    }
	}
    } else {
	for (my $line_no = @L; $line_no >= 1; $line_no--) {
	    $doline->($line_no);
	    last if $o->{errors} > 5;
	}
	if ($how < -1) {
	    $o->set_refcnt($e, 0);
	} else {
	    $o->refcnt_dec($e, $by);
	}
    }

    $o->t("[$how] $e DONE");
    $LOGIN ||= getlogin || getpwuid($<) || "?";
    push @{$o->{'log'}}, { when => time(), who => $LOGIN,
			   action => ($how<0?'un':'').'load',
			   what => $e };
}

# ---------------------------------------------------------------
# DURING TRANSACTION

sub envy { #PUBLIC
    my ($o, $reverse, $e) = @_;
    if ($reverse and $o->is_first($e)) {
	$o->unload_all();
    } else {
	my $how = $reverse?-100:100;
	$how=0 if !$reverse && $o->{loaded}{$e};
	$Loop = 0;
	local $Context = " while ".($reverse?"un":"")."loading envy '$e'.\n";
	$o->process_envy($how, $e, '1');
    }
}

sub unload_all { #PUBLIC
    my ($o) = @_;
    $Loop = 0;
    local $Context = " while unloading everything.\n";

    my @un = keys %{$o->{loaded}};
    while (@un) {
	@un = sort { $o->get_seniority($a) <=> $o->get_seniority($b) } @un;
	my $e = shift @un;
	next if !$o->{loaded}{$e};
	$o->process_envy(-100, $e, '1') if !$o->is_first($e);
    }
    # make sure we didn't shoot ourself in the foot
    $o->{unload_all}=1;
    $o->process_envy(-1, $o->{first}, '1');
    $o->process_envy(1, $o->{first}, '1');
    $o->{unload_all}=0;
}

# ---------------------------------------------------------------
# AFTER TRANSACTION COMMIT

sub write_log { #PUBLIC
    my ($o) = @_;
    confess "transaction in progress" if $o->{transaction};
    require FindBin;
    my $file = "$FindBin::Bin/../var/envy.log";
    my @stat = stat($file);
    if (@stat and $stat[7] > 1024 * 256) {
	$o->w("envy: rename $file $file.old: $!\n")
	    if !rename $file, "$file.old";
    }
    my $LOG = gensym;
    sysopen($LOG, $file, &O_WRONLY| &O_APPEND| &O_CREAT, 0666) or
	return $o->n("envy: open $file: $!");
    for my $e (@{$o->{'log'}}) {
	print $LOG (join("\t", scalar localtime($e->{when}),
			 $e->{who}, $o->{where}, $e->{action}, $e->{what})."\n");
    }