view release on metacpan or  search on metacpan

script/album  view on Meta::CPAN

    $mod;
}

################ ################

#### Persistent info (cache) helpers.

{ my $cache;

  my @stats; INIT{ @stats = (0, 0, 0); }

  sub load_cache {
    $cache = new ImageInfoCache
      ((!$clobber && -s d_dest(".cache")) ? d_dest(".cache") : undef);
  }

  sub update_cache {
    $cache->store(d_dest(".cache"));
  }

  sub cache_entry {
      if ( @_ == 1 ) {
	  $stats[0]++;
	  my $ii = $cache->entry(@_);
	  $stats[1]++ if $ii;
	  warn("Cache miss: $_[0]\n") if !$ii && $trace;
	  return $ii;
      }
      $stats[2]++;
      $cache->entry(@_);
  }

  END {
      print STDERR ("Cache: store = $stats[2], lookup = $stats[0], hits = $stats[1]\n")
	if $trace;
  }
}

#### Miscellaneous.

sub findexec {
    my ($bin) = @_;
    foreach ( File::Spec->path ) {
	my $try = File::Spec->catfile($_, $bin);
	return $try if -x $try;
    }
    undef;
}

sub squote {
    my ($t) = @_;
    $t =~ s/([\\\"])/\\$1/g;
    $t = '"'.$t.'"' if $t =~ /[^-\w.\/]/;
    $t;
}

################ Button Images ################

sub add_button_images {
    # Extract button images from DATA section.

    my $out = do { local *OUT; *OUT };
    my $name;
    my $doing = 0;
    my $did = 0;

    while ( <DATA> ) {
        if ( $doing ) {         # uudecoding...
            if ( /^Xend/ ) {
                close($out);
                $doing = 0;	# Done
		next;
            }
            # Select lines to process.
            next if /[a-z]/;
	    next unless /^X(.*)/s;
	    $_ = $1;
            next unless int((((ord() - 32) & 077) + 2) / 3)
              == int(length() / 4);
            # Decode.
            print $out unpack("u",$_);
            next;
        }

        # Otherwise, search for the uudecode 'begin' line.
        if ( /^Xbegin\s+\d+\s+(.+)$/ ) {
	    next if !$clobber && -s d_icons($1);
	    print STDERR ("Creating icons: ") if $verbose > 1 && !defined($name);
	    $did++;
            $name = d_icons($1);
	    print STDERR ("$1 ") if $verbose > 1;
            open($out, ">", $name);
	    binmode($out);
            $doing = 1;         # Doing
            next;
        }
    }
    print STDERR ("\n") if $verbose > 1;
    if ( $doing ) {
        die("Error in DATA: still processing $name\n");
        unlink($name);
    }
}

################ Style Sheets ################

################ End Style Sheets ################

sub detab {
    my ($line) = @_;
    return $line unless $line;
    my $orig = $line;
    my (@l) = split(/\t/, $line, -1);

    # Replace tabs with blanks, retaining layout

    $line = shift(@l);
    $line .= " " x (8-length($line)%8) . shift(@l) while @l;

    $line;
}

################ Copying: plain files ################

sub copy {
    my ($orig, $new, $time) = @_;

    $time = (stat($orig))[9] unless defined($time);

    my $in = do { local *F; *F };
    open($in, "<", $orig) or die("$orig: $!\n");
    binmode($in);

    my $out = do { local *F; *F };
    open($out, ">", $new) or die("$new: $!\n");
    binmode($out);

    my $buf;

    for (;;) {
	my ($r, $w, $t);
	defined($r = sysread($in, $buf, 10240))
	  or die("$orig: $!\n");
	last unless $r;
	for ( $w = 0; $w < $r; $w += $t ) {
	    $t = syswrite($out, $buf, $r - $w, $w)
	      or die("$new: $!\n");
	}
    }
    close($in);
    close($out) or die("$new: $!\n");
    utime($time, $time, $new);
}

################ Copying: MPG files ################

sub copy_mpg {
    my ($orig, $new, $time, $rotate, $mirror) = @_;
    $time = (stat($orig))[9] unless defined($time);