view release on metacpan or  search on metacpan

tools/make-images  view on Meta::CPAN

	$grid->append_row([ $cell->('Carol'), $cell->('carol@example.com'), $amount->('88.00') ]);
	$page->add_child(panel('Clay::UI::Grid: every column as wide as its widest cell', $grid));
	return ($page, []);
}

# The same text in a 200 wide parent under each wrap mode; the panels
# are stacked so that the overflow of the lower two stays visible.
sub build_text_wrapping ($state) {
	my $page = page(layout_direction => CLAY_TOP_TO_BOTTOM, child_gap => 12);
	my $sample = "Clay wraps this text to the width\nof its parent element.";
	for my $mode ([ 'CLAY_TEXT_WRAP_WORDS (the default)', CLAY_TEXT_WRAP_WORDS ], [ 'CLAY_TEXT_WRAP_NEWLINES', CLAY_TEXT_WRAP_NEWLINES ], [ 'CLAY_TEXT_WRAP_NONE', CLAY_TEXT_WRAP_NONE ]) {
		my ($title, $constant) = @$mode;
		my $column = container(layout => { sizing => { width => sizing_fixed(200) }, padding => padding_all(6) });
		$column->add_child(text($sample, wrap_mode => $constant));
		$page->add_child(panel($title, $column));
	}
	return ($page, []);
}

# ---------------------------------------------------------------------------
# Main
# ---------------------------------------------------------------------------

my $tag = TAG_PREFIX . $Clay::UI::VERSION;
my @names = (
	(map { "$_->{name}.png" } @figures),
	(map { "$_->{name}.$_->{extension}" } @example_outputs),
);
my $outdated = update_pod_pictures(pod_files('lib'), $tag, $options{check}, @names);

my $font = label_font();
for my $figure (@figures) {
	my $image = render_figure($figure, $font);
	$outdated += store_image($image, File::Spec->catfile($options{output}, "$figure->{name}.png"), $options{check});
}
my $scratch = tempdir(CLEANUP => 1);
for my $output (@example_outputs) {
	my $content = run_example($output->{script}, File::Spec->catfile($scratch, "$output->{name}.$output->{extension}"));
	my $file = File::Spec->catfile($options{output}, "$output->{name}.$output->{extension}");
	$outdated += store_if_changed($file, $content, $options{check});
}
exit($options{check} && $outdated ? 1 : 0);

# ---------------------------------------------------------------------------
# Pod checks
# ---------------------------------------------------------------------------

sub pod_files ($directory) {
	my @files;
	find({ no_chdir => 1, wanted => sub { push @files, $_ if /\.(?:pm|pod)\z/ } }, $directory);
	return [ sort @files ];
}

# Dies unless the pod files together show exactly the files this script
# renders: a PNG through an <img src="IMAGE_URL_BASE/TAG/images/NAME.png">
# tag preceded by a "=for text Figure: images/NAME.png" paragraph for
# readers without HTML, any other file through a link to
# FILE_URL_BASE/TAG/images/NAME.EXT. Then points every such URL to $tag.
# Returns the number of pod files that were (or, with $check_only, would
# be) changed.
sub update_pod_pictures ($pod_files, $tag, $check_only, @names) {
	my $image_url = qr{<img src="\Q@{[IMAGE_URL_BASE]}\E/[^"/]+/images/([^"/]+\.png)"};
	my $file_url  = qr{\Q@{[FILE_URL_BASE]}\E/[^\s/>]+/images/([^\s/>]+)};
	my (%shown, %updated_pods);
	for my $pod_file (@$pod_files) {
		my $pod = read_file($pod_file);
		my @bad_tags = grep { !/^$image_url/ } $pod =~ m{(<img\b[^>]*>)}g;
		die map {"$pod_file: $_ does not start with <img src=\"@{[IMAGE_URL_BASE]}/TAG/images/NAME.png\"\n"} @bad_tags if @bad_tags;
		for my $name ($pod =~ m{$image_url}g) {
			die "$pod_file: no '=for text Figure: images/$name' paragraph for the <img> that shows it\n"
				unless $pod =~ m{^=for text Figure: images/\Q$name\E\b}m;
			$shown{$name} = 1;
		}
		$shown{$_} = 1 for $pod =~ m{$file_url}g;

		(my $updated = $pod) =~ s{(<img src="\Q@{[IMAGE_URL_BASE]}\E/)[^"/]+/}{$1$tag/}g;
		$updated =~ s{(\Q@{[FILE_URL_BASE]}\E/)[^\s/>]+/}{$1$tag/}g;
		$updated_pods{$pod_file} = $updated if $updated ne $pod;
	}
	my %rendered = map { $_ => 1 } @names;
	my @problems = (
		(map {"the pod shows images/$_, which this script does not render\n"} grep { !$rendered{$_} } sort keys %shown),
		(map {"no pod shows images/$_\n"} grep { !$shown{$_} } @names),
	);
	die @problems if @problems;

	store_file($_, $updated_pods{$_}, $check_only) for sort keys %updated_pods;
	return scalar keys %updated_pods;
}

# ---------------------------------------------------------------------------
# Layout and rendering
# ---------------------------------------------------------------------------

sub label_font () {
	die "Imager was built without FreeType support; it is needed for the text\n"
		unless $Imager::formats{ft2};
	open(my $match, '-|', 'fc-match', '--format=%{file}', 'DejaVu Sans:style=Book')
		or die "cannot run fc-match: $!\n";
	my $file = <$match>;
	close($match);
	die "fc-match found no font\n" unless defined $file && -f $file;
	return Imager::Font->new(file => $file, aa => 1)
		// die Imager->errstr, "\n";
}

sub measure_with ($font) {
	return sub ($string, $config, $userdata) {
		my $size = $config->{fontSize};
		my $bbox = $font->bounding_box(string => drawable($string), size => $size);
		return { width => $bbox->advance_width, height => $bbox->font_height };
	};
}

# A text command may still hold newlines (CLAY_TEXT_WRAP_NONE keeps the
# whole text on one line); the font has no glyph for them, so they are
# drawn, and measured, as spaces.
sub drawable ($string) {
	(my $copy = $string) =~ tr/\n/ /;
	return $copy;
}