view release on metacpan or  search on metacpan

script/album  view on Meta::CPAN

  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 ################

my $add_stylesheet_msg;
sub add_stylesheets {
    my $css_fontfam = "font-family: Verdana, Arial, Helvetica";
    my $WHITE = "#FFFFFF";
    my $BLACK = "#000000";
    my $RED   = "#FF0000";
    my $LGREY = "#E0E0E0";
    my $MGREY = "#D0D0D0";
    my $DGREY = "#C0C0C0";

    $add_stylesheet_msg = 0;

    add_stylesheet("common", heredoc(<<"    EOD", 4));
    body {
	font-size:  80%; $css_fontfam;
	text: $BLACK;
	background: $DGREY;
    }
    td {
	font-size:  80%; $css_fontfam;
    }
    p.hdl, p.hdr {
	font-size: 140%; font-weight: bold;
	$css_fontfam;
    }
    p.ftl, p.ftr {
	font-size:  80%; $css_fontfam;
    }
    a:link {
	color: $BLACK; text-decoration: none;
    }
    a:visited {
	color: $BLACK; text-decoration: none;
    }
    a:active {
	color: $RED; text-decoration: none;
    }
    EOD

    add_stylesheet("index", heredoc(<<"    EOD", 4));
    \@import "common.css";
    a.info {
	position: relative; z-index: 24; background-color: $LGREY;
	color: $BLACK; text-decoration:none;
    }
    a.info:hover {
	z-index: 25; background-color: $LGREY;

script/album  view on Meta::CPAN

    a.info:hover span {
	display: block;
	position: absolute; top: 2em; left: 2em; width: 15em;
	border: 0px; background-color: $MGREY; color :$BLACK;
	text-align: center;
    }
    EOD

    add_stylesheet("medium", heredoc(<<"    EOD", 4));
    \@import "common.css";
    a.info {
	position: relative; z-index: 24; background-color: $DGREY;
	color:$BLACK; text-decoration:none;
    }
    a.info:hover {
	z-index: 25; background-color: $DGREY;
    }
    a.info span {
	display: none;
    }
    a.info:hover span {
	display: block;
	position: absolute; top:2em; left: 2em; width: 15em;
	border: 0px; background-color: $MGREY; color: $BLACK;
	text-align: center;
    }
    EOD

    add_stylesheet("journal", heredoc(<<"    EOD", 4));
    body {
	font-size: 100%; $css_fontfam;
	text: $BLACK;
	background: $WHITE;
    }
    p.hd {
	font-size: 140%; font-weight: bold;
	margin-left: 0.1in; margin-top: 0.1in; margin-bottom: 0.1in;
    }
    table.outer {
	width: 500px;
	border-spacing: 10px;
    }
    tr.grey {
	background: $DGREY;
    }
    table.outer td {
    }
    EOD

    print STDERR ("\n") if $add_stylesheet_msg;
}

sub add_stylesheet {
    my ($css, $data) = @_;
    return if -e d_css("$css.css");
    print STDERR ("Creating style sheets: ")
      unless $verbose <= 1 || $add_stylesheet_msg++;
    print STDERR ("$css.css ");
    $css = d_css("$css.css");
    open(my $out, ">".$css) or die("$css: $!\n");
    binmode($out);
    print {$out} ($data);
    close($out) or die("$css: $!\n");
}

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

sub detab {
    my ($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);

    # I'm not sure what this does. The resultant file is about 10% of
    # the original, without missing something...
    my $cmd = "$prog_mencoder -of mpeg -oac copy -ovc ".
	($rotate ? "lavc -lavcopts vcodec=mpeg1video -vop rotate=".int($rotate/90)." " : "copy ") .
	  squote($orig) . " -o ". squote($new);
    warn("\n+ $cmd\n") if $verbose > 2;

    my $res = `$cmd 2>&1`;
    die("${res}Aborted\n") if $?;

    utime($time, $time, $new);
}

sub still {
    my ($el) = @_;

    my $new = d_large($el->assoc_name);
    my $still = new Image::Magick;
    if ( $prog_mplayer ) {
	my $tmp = "00000001.jpg";
	my $tmp2 = "00000002.jpg";
	if ( -e $tmp ) {
	    die("ERROR: mplayer needs to create a file $tmp, but it already exists!\n");
	}
	# Sometimes, -frames 1 does not produce anything. Need -frames 2.
	my $cmd = "$prog_mplayer -really-quiet -nojoystick -nolirc -nosound -frames 2 -vo jpeg " .
	  squote(d_large($el->dest_name));
	warn("\n+ $cmd\n") if $verbose > 2;
	my $t = `$cmd 2>&1`;
	warn("$t\n") unless -s $tmp;
	$still->Read($tmp);
	unlink($tmp, $tmp2);
    }
    else {
	# This may take minutes.
	$still->Read(d_large($el->dest_name)."[0]");