#
# perltidy - a perl script indenter and formatter
#
-# Copyright (c) 2000-2018 by Steve Hancock
+# Copyright (c) 2000-2019 by Steve Hancock
# Distributed under the GPL license agreement; see file COPYING
#
# This program is free software; you can redistribute it and/or modify
while ( my $input_file = shift @ARGV ) {
my $fileroot;
- my @input_file_stat;
+ my @input_file_stat;
#---------------------------------------------------------------
# prepare this input stream
# we should have a valid filename now
$fileroot = $input_file;
- @input_file_stat = stat($input_file);
+ @input_file_stat = stat($input_file);
if ( $^O eq 'VMS' ) {
( $fileroot, $dot ) = check_vms_filename($fileroot);
# set output file permissions
if ( $output_file && -f $output_file && !-l $output_file ) {
- if ( @input_file_stat ) {
+ if (@input_file_stat) {
- # Set file ownership and permissions
+ # Set file ownership and permissions
if ( $rOpts->{'format'} eq 'tidy' ) {
my ( $mode_i, $uid_i, $gid_i ) =
@input_file_stat[ 2, 4, 5 ];
my $input_file_permissions = $mode_i & oct(7777);
my $output_file_permissions = $input_file_permissions;
- #rt128477: avoid inconsistent owner/group and suid/sgid
+ #rt128477: avoid inconsistent owner/group and suid/sgid
if ( $uid_i != $uid_o || $gid_i != $gid_o ) {
- # try to change owner and group to match input file if in -b mode
- # note: chown returns number of files successfully changed
+ # try to change owner and group to match input file if in -b mode
+ # note: chown returns number of files successfully changed
if ( $in_place_modify
&& chown( $uid_i, $gid_i, $output_file ) )
{
- # owner/group successfully changed
+ # owner/group successfully changed
}
else {
# owner or group differ: do not copy suid and sgid
$output_file_permissions = $mode_i & oct(777);
- if ( $input_file_permissions != $output_file_permissions ) {
+ if ( $input_file_permissions !=
+ $output_file_permissions )
+ {
Warn(
"Unable to copy setuid and/or setgid bits for output file '$output_file'\n"
);
}
}
- # The output file must be user writable if we are not in -b
- # mode; otherwise a rerun of perltidy will fail.
+ # Make the output file writable unless we are in -b mode.
+ # The issue is that perltidy currently does not unlink
+ # existing output files before writing to them, so if an
+ # existing output file (like xxxxx.tdy) is read-only then
+ # perltidy will fail.
if ( !$in_place_modify ) {
$output_file_permissions |= oct(600);
}
if ( !chmod( $output_file_permissions, $output_file ) ) {
# couldn't change file permissions
- my $operm = sprintf "%04o", $output_file_permissions;
+ my $operm = sprintf "%04o", $output_file_permissions;
Warn(
"Unable to set permissions for output file '$output_file' to $operm\n"
);
$add_option->( 'maximum-consecutive-blank-lines', 'mbl', '=i' );
$add_option->( 'keep-old-blank-lines', 'kbl', '=i' );
- $add_option->( 'keyword-group-blanks-list', 'kgbl', '=s' );
- $add_option->( 'keyword-group-blanks-size', 'kgbs', '=s' );
- $add_option->( 'keyword-group-blanks-repeat-count', 'kgbr', '=i' );
- $add_option->( 'keyword-group-blanks-before', 'kgbb', '=i' );
- $add_option->( 'keyword-group-blanks-after', 'kgba', '=i' );
- $add_option->( 'keyword-group-blanks-inside', 'kgbi', '!' );
- $add_option->( 'keyword-group-blanks-delete', 'kgbd', '!' );
+ $add_option->( 'keyword-group-blanks-list', 'kgbl', '=s' );
+ $add_option->( 'keyword-group-blanks-size', 'kgbs', '=s' );
+ $add_option->( 'keyword-group-blanks-repeat-count', 'kgbr', '=i' );
+ $add_option->( 'keyword-group-blanks-before', 'kgbb', '=i' );
+ $add_option->( 'keyword-group-blanks-after', 'kgba', '=i' );
+ $add_option->( 'keyword-group-blanks-inside', 'kgbi', '!' );
+ $add_option->( 'keyword-group-blanks-delete', 'kgbd', '!' );
$add_option->( 'blank-lines-after-opening-block', 'blao', '=i' );
$add_option->( 'blank-lines-before-closing-block', 'blbc', '=i' );
print STDOUT <<"EOM";
This is perltidy, v$VERSION
-Copyright 2000-2018, Steve Hancock
+Copyright 2000-2019, Steve Hancock
Perltidy is free software and may be copied under the terms of the GNU
General Public License, which is included in the distribution files.
my $token = $rLL->[$K_first]->[_TOKEN_];
my $ci_level = $rLL->[$K_first]->[_CI_LEVEL_];
- # see if this is a code type we seek (i.e. comment)
+ # see if this is a code type we seek (i.e. comment)
if ( $CODE_type
&& $Opt_comment_pattern
&& $CODE_type =~ /$Opt_comment_pattern/o )
return $rhash_of_desires;
}
-
sub break_lines {
# Loop over old lines to set new line break points
# }
# }
- # But while this would be a trivial update, it would have very undesirable
- # side effects when perltidy is run from within an editor on a small snippet.
- # So this is best done with a separate filter, such
- # as 'delete_ending_blank_lines.pl' in the examples folder.
+ # But while this would be a trivial update, it would have very undesirable
+ # side effects when perltidy is run from within an editor on a small snippet.
+ # So this is best done with a separate filter, such
+ # as 'delete_ending_blank_lines.pl' in the examples folder.
# Flag to prevent blank lines when POD occurs in a format skipping sect.
my $in_format_skipping_section;
my $rwant_blank_line_after = $self->keyword_group_scan();
my $line_type = "";
- my $i = -1;
+ my $i = -1;
foreach my $line_of_tokens ( @{$rlines} ) {
- $i++;
+ $i++;
- # insert blank lines requested for keyword sequences
+ # insert blank lines requested for keyword sequences
if ( $i > 0
&& defined( $rwant_blank_line_after->{ $i - 1 } )
&& $rwant_blank_line_after->{ $i - 1 } == 1 )
# old blank lines and let the blank line rules generate any
# needed blanks.
- # We also delete lines requested by the keyword-group logic
+ # We also delete lines requested by the keyword-group logic
my $kgb_keep = !( defined( $rwant_blank_line_after->{$i} )
&& $rwant_blank_line_after->{$i} == 2 );
- # But the keep-old-blank-lines flag has priority over kgb flags
- $kgb_keep = 1 if ($rOpts_keep_old_blank_lines == 2 );
+ # But the keep-old-blank-lines flag has priority over kgb flags
+ $kgb_keep = 1 if ( $rOpts_keep_old_blank_lines == 2 );
- if ($rOpts_keep_old_blank_lines && $kgb_keep) {
+ if ( $rOpts_keep_old_blank_lines && $kgb_keep ) {
$self->flush();
$file_writer_object->write_blank_code_line(
$rOpts_keep_old_blank_lines == 2 );
# a real semicolon for one_line_block option = 2
my $tok = $rOpts_one_line_block_semicolons == 2 ? ';' : '';
- $rLL_new->[$Ktop]->[_TOKEN_] = $tok; # zero length if phantom
+ $rLL_new->[$Ktop]->[_TOKEN_] = $tok; # zero length if phantom
$rLL_new->[$Ktop]->[_TYPE_] = ';';
$rLL_new->[$Ktop]->[_SLEVEL_] =
$rLL->[$KK]->[_SLEVEL_];
$weld_len_right_opening{$outer_seqno} = 2;
# QW PATCH 1 (Testing)
- # undo CI for welded quotes
- foreach my $K($Kn .. $Kt_end ) {
- $rLL->[$K]->[_CI_LEVEL_]=0;
- }
-
- # Change the level of a closing qw token to be that of the outer
- # containing token. This will allow -lp indentation to function
- # correctly in the vertical aligner.
+ # undo CI for welded quotes
+ foreach my $K ( $Kn .. $Kt_end ) {
+ $rLL->[$K]->[_CI_LEVEL_] = 0;
+ }
+
+ # Change the level of a closing qw token to be that of the outer
+ # containing token. This will allow -lp indentation to function
+ # correctly in the vertical aligner.
$rLL->[$Kt_end]->[_LEVEL_] = $rLL->[$K_closing]->[_LEVEL_];
}
}
make_bli_pattern();
make_block_brace_vertical_tightness_pattern();
make_blank_line_pattern();
- make_keyword_group_list_pattern();
+ make_keyword_group_list_pattern();
prepare_cuddled_block_types();
if ( $rOpts->{'dump-cuddled-block-list'} ) {
my $lc = $nonblank_lines_at_depth[$last_line_leading_level];
if ( !defined($lc) ) { $lc = 0 }
- # patch for RT #128216: no blank line inserted at a level change
+ # patch for RT #128216: no blank line inserted at a level change
if ( $levels_to_go[$imin] != $last_line_leading_level ) {
$lc = 0;
}
if ( $accumulating_text_for_block !~ /^els/ ) {
$rleading_block_if_elsif_text = [];
}
- $leading_block_text = "";
- $leading_block_text_level = $levels_to_go[$i];
- $leading_block_text_line_number = get_output_line_number();
+ $leading_block_text = "";
+ $leading_block_text_level = $levels_to_go[$i];
+ $leading_block_text_line_number = get_output_line_number();
$leading_block_text_length_exceeded = 0;
# this will contain the column number of the last character
# within this container, and it helps avoid undesirable
# alignments of different types of containers.
- # Containers beginning with { and [ are given those names
- # for uniqueness. That way commas in different containers
- # will not match. Here is an example of what this prevents:
- # a => [ 1, 2, 3 ],
- # b => { b1 => 4, b2 => 5 },
- # Here is another example of what we avoid by labeling the
- # commas properly:
- # is_d( [ $a, $a ], [ $b, $c ] );
- # is_d( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
- # is_d( [ \$a, \$a ], [ \$b, \$c ] );
+ # Containers beginning with { and [ are given those names
+ # for uniqueness. That way commas in different containers
+ # will not match. Here is an example of what this prevents:
+ # a => [ 1, 2, 3 ],
+ # b => { b1 => 4, b2 => 5 },
+ # Here is another example of what we avoid by labeling the
+ # commas properly:
+ # is_d( [ $a, $a ], [ $b, $c ] );
+ # is_d( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
+ # is_d( [ \$a, \$a ], [ \$b, \$c ] );
my $name = $tok;
if ( $tok eq '(' ) {
my $ibeg_weld_fix = $ibeg;
# QW PATCH 2 (Testing)
- # At an isolated closing token of a qw quote which is welded to
- # a following closing token, we will locally change its type to
- # be the same as its token. This will allow formatting to be the
- # same as for an ordinary closing token.
-
- # For -lp formatting se use $ibeg_weld_fix to get around the problem
- # that with -lp type formatting the opening and closing tokens to not
- # have sequence numbers.
+ # At an isolated closing token of a qw quote which is welded to
+ # a following closing token, we will locally change its type to
+ # be the same as its token. This will allow formatting to be the
+ # same as for an ordinary closing token.
+
+ # For -lp formatting se use $ibeg_weld_fix to get around the problem
+ # that with -lp type formatting the opening and closing tokens to not
+ # have sequence numbers.
if ( $type_beg eq 'q' && $token_beg =~ /^[\)\}\]\>]/ ) {
my $K_next_nonblank = $self->K_next_code($K_beg);
if ( defined($K_next_nonblank) ) {
my $welded = weld_len_left( $type_sequence, $token );
if ($welded) {
$ibeg_weld_fix = $ibeg + ( $K_next_nonblank - $K_beg );
- $type_beg = ')'; ##$token_beg;
+ $type_beg = ')'; ##$token_beg;
}
}
}
if ( $type eq '->' ) {
if ($rOpts_break_at_old_method_breakpoints) {
- # Case 1: look for lines with leading pointers
+ # Case 1: look for lines with leading pointers
if ( $i == $i_line_start ) {
set_forced_breakpoint( $i - 1 );
}
- # Case 2: look for cuddled pointer calls
+ # Case 2: look for cuddled pointer calls
else {
- # look for old lines with leading ')->' or ') ->'
- # and, when found, force a break before the
- # opening paren and after the previous closing paren.
+ # look for old lines with leading ')->' or ') ->'
+ # and, when found, force a break before the
+ # opening paren and after the previous closing paren.
if (
$types_to_go[$i_line_start] eq '}'
&& ( $i == $i_line_start + 1
)
{
set_forced_breakpoint( $i_line_start - 1 );
- set_forced_breakpoint($mate_index_to_go[$i_line_start]);
+ set_forced_breakpoint(
+ $mate_index_to_go[$i_line_start] );
}
}
}
my $rLL = $self->{rLL};
my $K_opening_container = $self->{K_opening_container};
- # Walk down the lines of this batch and delete any semicolons
- # terminating one-line blocks;
+ # Walk down the lines of this batch and delete any semicolons
+ # terminating one-line blocks;
my $nmax = @{$ri_end} - 1;
foreach my $n ( 0 .. $nmax ) {
if ( defined($K_end) ) { $type_end = $rLL->[$K_end]->[_TYPE_]; }
}
- # we are looking for a line ending in closing brace
+ # we are looking for a line ending in closing brace
next
unless ( $type_end eq '}' && $rLL->[$K_end]->[_TOKEN_] eq '}' );
- # ...and preceded by a semicolon on the same line
+ # ...and preceded by a semicolon on the same line
my $K_semicolon = $self->K_previous_nonblank($K_end);
my $i_semicolon = $i_beg + ( $K_semicolon - $K_beg );
next if ( $i_semicolon <= $i_beg );
next unless ( $rLL->[$K_semicolon]->[_TYPE_] eq ';' );
- # safety check - shouldn't happen
- if ($types_to_go[$i_semicolon] ne ';') {
- Fault("unexpected type looking for semicolon, ignoring");
- next;
- }
+ # safety check - shouldn't happen
+ if ( $types_to_go[$i_semicolon] ne ';' ) {
+ Fault("unexpected type looking for semicolon, ignoring");
+ next;
+ }
- # ... with the corresponding opening brace on the same line
+ # ... with the corresponding opening brace on the same line
my $type_sequence = $rLL->[$K_end]->[_TYPE_SEQUENCE_];
my $K_opening = $K_opening_container->{$type_sequence};
my $i_opening = $i_beg + ( $K_opening - $K_beg );
next if ( $i_opening < $i_beg );
- # ... and only one semicolon between these braces
- my $semicolon_count=0;
- foreach my $K ( $K_opening + 1 .. $K_semicolon-1 ) {
- if ($rLL->[$K]->[_TYPE_] eq ';') {
- $semicolon_count++;
- last;
- }
+ # ... and only one semicolon between these braces
+ my $semicolon_count = 0;
+ foreach my $K ( $K_opening + 1 .. $K_semicolon - 1 ) {
+ if ( $rLL->[$K]->[_TYPE_] eq ';' ) {
+ $semicolon_count++;
+ last;
+ }
}
- next if ($semicolon_count);
+ next if ($semicolon_count);
- # ...ok, then make the semicolon invisible
+ # ...ok, then make the semicolon invisible
$tokens_to_go[$i_semicolon] = "";
}
return;
projects / perltidy.git / commitdiff